StackOverflow2013

Note that there are some explanatory texts on larger screens.

plurals

POSearch for proper column and find duplicates - macro amendment needed [VBA]
text
Body
copied!<p>I have a VBA Macro for excel to find duplicates. It works but it is specified to a certain column. I would like to search through column headers which are in the 1st row and find the header called "Email" (the best would be "Email*" as sometimes this header contains some other words after the "Email" word). I think this script doesn't adjust to the number of rows and it is limited to 65536 values. I would prefer to let this script adjust to the number of values in the column. I have a similar VBA macro which does the perfect job. I thought I would be able to use this macro as an example and amend the one which I am currently working on...however I failed. Could anyone help me to do the proper amendments to the first code?</p> <p><strong>VBA MACRO WHICH I WOULD LIKE TO AMEND:</strong></p> <pre><code>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 </code></pre> <p><strong>VBA MACRO WHICH WORKS FINE AND I WANTED TO USE AS AN EXAMPLE:</strong></p> <pre><code>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 </code></pre> <p><strong>MY WORK SO FAR</strong></p> <pre><code>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 </code></pre> <hr> <p>Seems to be more complicated and as I mentioned I have limited knowledge of VBA. However, I found a different script which might be easier to amend.</p> <p>This macro finds the email address column and marks the whole column</p> <pre><code>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 </code></pre> <p>This one finds duplicates using countif function (which is good to me. The only problem is that I have this macro as a button, where the range is specified</p> <pre><code>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 </code></pre> <p>Then the action button:</p> <pre><code>Private Sub CommandButton1_Click() Highlight_Duplicates (Sheets("Test").Range("C2:C92")) End Sub </code></pre> <p>It is fine for me to run 1st macro and then the 2nd. However, I don't know how to get rid of Range in the action button. Any ideas?</p>

Querying!

Guidance

An individual column

Larger individual text columns get their own page to allow for proper reading.

SQuiL has stopped working due to an internal error.

If you are curious you may find further information in the browser console, which is accessible through the devtools (F12).

Reload