如何解决试图在列的每个单元格中查找重复的逗号分隔文本
我从某人那里得到了以下宏,并尝试修改它以适合我的目的。
我正在尝试更改此宏以查找并突出显示每个单元格中具有重复值的单元格, 例如,它应该突出显示 B62 和 B63(绿色), 和颜色字体红色重复值(即 B62 中的 B_HWY_1010 和 B63 中的 B_HWY_1015)
Sub Dupes()
Dim d As Object
Dim a As Variant,itm As Variant
Dim i As Long,k As Long
Dim rng As Range
Dim bColoured As Boolean
Set d = CreateObject("Scripting.Dictionary")
Set rng = Range("B1",Range("B" & Rows.Count).End(xlUp))
a = rng.Value
For i = 1 To UBound(a)
For Each itm In Split(a(i,1),",")
d(itm) = d(itm) + 1
Next itm
Next i
Application.ScreenUpdating = False
For i = 1 To UBound(a)
k = 1
bColoured = False
For Each itm In Split(a(i,")
If d(itm) > 1 Then
If Not bColoured Then
rng.Cells(i).Interior.Color = vbGreen
bColoured = True
End If
rng.Cells(i).Characters(k,Len(itm)).Font.Color = RGB(244,78,189)
End If
k = k + Len(itm) + 1
Next itm
Next i
Application.ScreenUpdating = True
End Sub
感谢任何帮助或建议。
解决方法
以下将做到这一点
Option Explicit
Public Sub Example()
Dim Cell As Range
For Each Cell In Range("A1:A10")
HighlightRepetitions Cell,","
Next Cell
End Sub
Private Sub HighlightRepetitions(ByVal Cell As Range,ByVal Delimiter As String)
If Cell.HasFormula Or Cell.HasArray Then Exit Sub ' don't run on formulas
Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
Dim Data() As String
Data = Split(Cell.Value,Delimiter) ' split data in the cell by Delimiter
Dim StrLen As Long ' length of the string that was already processed
Dim i As Long
For i = LBound(Data) To UBound(Data) ' loop through all data items
Dim DataLen As Long
DataLen = Len(Data(i)) 'get length of current item
If Dict.Exists(Data(i)) Then
' item is a repetition: color it
Cell.Characters(StrLen + 1,DataLen).Font.Color = vbRed
Cell.Interior.Color = vbGreen
Else
' item is no repetition: add it to the dictionary
Dict.Add Data(i),Data(i)
End If
StrLen = StrLen + DataLen + Len(Delimiter) ' calculate the length of the processed string and add length of the delimiter
Next i
End Sub
以下项目将被着色:
您可以在循环 ScreenUpdating
之前关闭 Sub Example()
,并在循环之后打开以阻止其闪烁。请注意,这不会在公式上运行,因为部分公式结果不能着色。这可以通过使用 If Cell.HasFormula Or Cell.HasArray Then Exit Sub
作为第一行来防止。
请也尝试下一个代码:
Sub findComaDelDuplicates()
Dim sh As Worksheet,arr,itm,arrInt,i As Long,rngS As Range,pos As Long
Dim arrDif As Long,j As Long,startPos As Long,arrPos,k As Long,mtch
Set sh = ActiveSheet
With sh.Range("B1",Range("B" & sh.rows.count).End(xlUp))
arr = .value 'put the range value in an array to make the iteration faster
.ClearFormats 'clear previous format
.Font.Color = vbBlack 'make the font color black
End With
For i = 1 To UBound(arr) 'iterate between the array elements:
arrInt = Split(arr(i,1),") 'split the content by comma delimiter
ReDim arrPos(UBound(arrInt)) 'redim the array keeping elements already formatted
For Each itm In arrInt 'iterate between the comma separated elements
arrDif = UBound(arrInt) - 1 - UBound(Filter(arrInt,False)) 'find how many times an element exists
If arrDif > 0 Then 'if more then an occurrence:
If rngS Is Nothing Then 'if range to be colored (at once) does not exist:
Set rngS = sh.Range("B" & i) 'it is crated
Else
Set rngS = Union(rngS,sh.Range("B" & i)) 'a union is made from the previous range and the new one
End If
mtch = Application.match(itm,0) 'check if the itm was already processed:
If IsError(mtch) Then 'if itm was not processed:
For j = 1 To arrDif + 1 'iterate for number of occurrences times
If j = 1 Then startPos = 1 Else: startPos = pos + 1 'first time,inStr starts from 1,then after the first occurrence
pos = InStr(startPos,sh.Range("B" & i).value,itm) 'find first character position for the itm to be colored
sh.Range("B" & i).Characters(pos,Len(itm)).Font.Color = vbRed 'color it
Next j
arrPos(k) = itm 'add the processed itm in the array
End If
End If
Next
Erase arrInt 'clear the array for the next cell value
Next i
If Not rngS Is Nothing Then rngS.Interior.Color = vbGreen 'color the interior cells of the built range
End Sub
注意:上面的代码将范围放入数组中以更快地迭代。但是,如果范围不是从第一行开始,则必须通过将行添加到 i
来获得要处理的单元格,直到范围的第一行。可以修改代码来做这种关联,但是我现在懒得做...:)
版权声明:本文内容由互联网用户自发贡献,该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 dio@foxmail.com 举报,一经查实,本站将立刻删除。