Question

我目前正在创建一个VBA宏，它将搜索名为“电子邮件”或“电子邮件 - 个人电子邮件”的列（这是相同的列，但这两个名称是替代品）。

首先搜索“电子邮件”列，然后找到，然后检查电子邮件地址末尾是否有任何点。如果是，则应删除它们。

我的VBA知识有限，我不是IT主管。所以我主要使用和修改我在互联网上找到的现有脚本。下面是我组合2个宏的代码。它工作正常但仅当电子邮件列位于相同位置时（在本例中为列S）。我应该如何修改代码以使用已发现电子邮件标题的列？

我的代码：

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

以下内容应该有效

'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

范围=在[vba]之前找到的列

1 个答案: