1

重複を見つけるための Excel 用の VBA マクロがあります。動作しますが、特定の列に指定されています。1行目にある列ヘッダーを検索して、「Email」というヘッダーを見つけたいと思います（このヘッダーには「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 マクロと例として使用したい:

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

最初のマクロを実行してから 2 番目のマクロを実行しても問題ありません。しかし、アクションボタンの範囲を取り除く方法がわかりません。何か案は？

4

1 に答える 1

0

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 」などのワイルドカード ヘッダーを渡して、一致するすべての列を取得できます。

于 2013-02-11T19:45:44.040 に答える