Question

I work currently to create a VBA macro which will search for the column called “Email” or “Email – personal email” (this is the same column but these 2 names are substitutes).

So first search for the Email column, while found then check if there are any dots at the end of the email addresses. If yes it should delete them.

I have limited VBA knowledge and I am not the IT preson. So I mostly use and amend existing scripts which I found on the internet. Below is the code which I made combining 2 macros. It works fine but only when the email column is in the same place (in this case column S). How should I amend the code to use the column where Email header had been spotted?

My code:

Sub GOOD_WORKS_No_Dots_at_End_of_Emails()
    Dim strSearch As String
    Dim aCell As Range

    strSearch = "Email*"

    Set aCell = Sheet2.Rows(1).Find(What:=strSearch, LookIn:=xlValues, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)

    If Not aCell Is Nothing Then
        Sheets("Data").Activate
            Dim LR As Long, i As Long
            LR = Range("S" & Rows.Count).End(xlUp).Row
            For i = 1 To LR
                With Range("S" & i)
                    If Right(.Value, 1) = "." Then .Value = Left(.Value, Len(.Value) - 1)
                End With
            Next i
            Sheets("Automation").Activate
            MsgBox "No Dots at the end of email addresses - Done!"
            End If
End Sub

Answer 1

the following should work

'rowNum<~~~ Enter the row number your "Header fields" are in
 'returns a dictionary object
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