search适当的列并find重复项 – macros需要修改
我有一个Excel的VBAmacros查找重复。 它的作品，但它是指定到某一列。 我想search第一行的列标题，find名为“电子邮件”的标题（最好是“电子邮件*”，因为有时这个标题包含“电子邮件”字后面的一些其他词）。 我认为这个脚本不适合行数，它被限制为65536个值。 我宁愿让这个脚本调整到列中的值的数量。 我有一个类似的VBAmacros，它完美的工作。 我想我可以用这个macros作为例子，修改一下我目前的工作，但是我失败了。 任何人都可以帮助我对第一个代码做适当的修改吗？
VBAmacros观，我想要修改：
Option Explicit Sub DeleteDups() Dim x As Long Dim LastRow As Long Sheets("test").Activate LastRow = Range("A65536").End(xlUp).Row For x = LastRow To 1 Step -1 If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then Range("A" & x).Interior.Color = RGB(255, 48, 48) End If Next x End Sub VBAmacros伟的工作很好，我想要使用作为一个例子：
Function getAllColNum(ByVal rowNum As Long, ByVal searchString As Variant) As Object Dim allColNum As Object Dim i As Long Dim j As Long Dim width As Long Set allColNum = CreateObject("Scripting.Dictionary") colNum = 1 With ActiveSheet width = .Cells(rowNum, .Columns.Count).End(xlToLeft).Column For i = 1 To width If InStr(UCase(Trim(.Cells(rowNum, i).Value)), UCase(Trim(searchString))) > 0 Then allColNum.Add i, "" End If ' Next i End With Set getAllColNum = allColNum End Function Sub GOOD_WORKS_No_Dots_at_End_of_Emails() Dim strSearch As String strSearch = "Email" Dim colNum As Variant Dim allColNum As Object Sheets("Data").Activate Dim LR As Long, i As Long Set allColNum = getAllColNum(1, searchString) For Each colNum In allColNum LR = Cells(Rows.Count, colNum).End(xlUp).Row For i = 1 To LR With Range(Cells(i, colNum), Cells(i, colNum)) If Right(.Value, 1) = "." Then .Value = Left(.Value, Len(.Value) - 1) End With Next i Next colNum Sheets("Automation").Activate MsgBox "No Dots at the end of email addresses - Done!" End Sub
我的工作很远
Function getAllColNum(ByVal rowNum As Long, ByVal searchString As Variant) As Object Dim allColNum As Object Dim i As Long Dim j As Long Dim width As Long Set allColNum = CreateObject("Scripting.Dictionary") colNum = 1 With ActiveSheet width = .Cells(rowNum, .Columns.Count).End(xlToLeft).Column For i = 1 To width If UCase(Trim(.Cells(rowNum, i).Value)) Like UCase(Trim(searchString)) Then allColNum.Add i, "" End If ' Next i End With Set getAllColNum = allColNum End Function Sub testing_testing() Dim strSearch As String strSearch = "Email" Dim colNum As Variant Dim allColNum As Object Sheets("Data").Activate Dim LR As Long, i As Long Set allColNum = getAllColNum(1, searchString) For Each colNum In allColNum LR = Cells(Rows.Count, colNum).End(xlUp).Row For i = 1 To LR With Range(Cells(i, colNum), Cells(i, colNum)) If Application.WorksheetFunction.CountIf(Range("R1:A" & x), Range("R" & x).Text) > 1 Then Range("A" & x).Interior.Color = RGB(255, 48, 48) End With End If Next i Next colNum Sheets("Automation").Activate MsgBox "Finiding duplicates - Done!" End Sub
似乎更复杂，正如我所提到的，我对VBA的了解有限。 但是，我发现了一个不同的脚本，可能更容易修改。
此macros查找电子邮件地址列并标记整列
Option Explicit Sub GOOD_WORKS_Mark_Email_Duplicates() Dim x As Long Dim LastRow As Long Sheets("test").Activate LastRow = Range("A65536").End(xlUp).Row For x = LastRow To 1 Step -1 If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then Range("A" & x).Interior.Color = RGB(255, 48, 48) End If Next x MsgBox "Email duplicates has been marked - red cells. Check if there are any red cells in the Email column" End Sub
这个使用countif函数find重复项（这对我很好，唯一的问题是我有这个macros作为一个button，其中的范围是指定的
Sub Highlight_Duplicates(Values As Range) Dim Cell For Each Cell In Values If WorksheetFunction.CountIf(Values, Cell.Value) > 1 Then Cell.Interior.ColorIndex = 6 End If Next Cell End Sub
然后操作button：
Private Sub CommandButton1_Click() Highlight_Duplicates (Sheets("Test").Range("C2:C92")) End Sub
对我来说，运行第一个macros，然后是第二个。 但是，我不知道如何摆脱动作button中的范围。 有任何想法吗？
在你的getAllColNum函数中，改变这个：
If InStr(UCase(Trim(.Cells(rowNum, i).Value)), _ UCase(Trim(searchString))) > 0 Then
对此：
If UCase(Trim(.Cells(rowNum, i).Value)) Like UCase(Trim(searchString)) Then
这将允许你传递一个像“ email ”的通配符头并获得所有匹配的列。