Question

我有一个用于excel的VBA宏来查找重复项。它可以工作，但它被指定到某个列。我想搜索第一行中的列标题并找到名为“Email”的标题（最好是“Email *”，因为有时此标题包含“电子邮件”字后面的其他一些单词）。我认为此脚本不会调整行数，并且限制为65536个值。我宁愿让这个脚本调整到列中的值的数量。我有一个类似的VBA宏，它完美的工作。我以为我可以使用这个宏作为例子并修改我目前正在处理的那个......但是我失败了。任何人都可以帮我对第一个代码进行适当的修改吗？

我想要修改的VBA宏：

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

VBA MACRO工作精细，我想用作例子：

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的了解有限。但是，我发现了一个可能更容易修改的不同脚本。

此宏找到电子邮件地址列并标记整列

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函数找到重复项（这对我很好。唯一的问题是我将这个宏作为按钮，指定了范围

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

然后是动作按钮：

Private Sub CommandButton1_Click()
Highlight_Duplicates (Sheets("Test").Range("C2:C92"))

End Sub

我可以运行第一个宏，然后运行第二个宏。但是，我不知道如何在动作按钮中摆脱Range。有什么想法吗？

Answer 1

在你的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

这将允许您传递通配符标题，如“电子邮件”并获取所有匹配的列。

搜索正确的列并查找重复项 - 需要进行宏修改[VBA]

1 个答案: