查找所有匹配项并复制侧列的值 <>""

Question

我有两张表（“客户”、“订单”）。我想通过电话号码匹配两者。

在订单表中，我有下表：

在客户表中，我有一个电话列表。

我正在尝试循环访问“客户”列中的所有数字，在“订单”表中找到匹配项，其中包含侧列值中的邮件。

我正在努力退出循环，因为我没有更改我的变量“c”，当它不在第一行时，它甚至找不到邮件。

Dim wb As Workbook
Dim ws_clients As Worksheet
Dim ws_orders As Worksheet
Dim Lastrow As Long
Dim Phone_LookUp As Variant

Set wb = Application.ActiveWorkbook

Dim firstAddress As String
Dim finalrow As Long, i As Long
Dim shtCS As Worksheet, shtFD As Worksheet, rw As Range
Dim c As Range

Set shtCS = wb.Sheets("Clients")
Set shtFD = wb.Sheets("Orders")

finalrow = shtCS.Range("A" & Rows.Count).End(xlUp).Row

With shtFD.Columns(3)
    For i = 2 To finalRow
        Set c = .Find(shtCS.Cells(i, 13).Value)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                If c.Offset(0, 1).Value <> "" Then
                    shtCS.Cells(i, 22).Value = c.Offset(0, 1).Value
                    i = i + 1
                End If
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    Next i
End With

Answer 1

被认定为根据订单明细更改客户单的email。使用字典可以减少循环。

Sub test()

    Dim wb As Workbook
    Dim ws_clients As Worksheet
    Dim ws_orders As Worksheet
    Dim Lastrow As Long
    Dim Phone_LookUp As Variant
    
    Dim vDB As Variant, vR As Variant
    Dim vPhone As Variant
    Dim Dic As Object 'Dictionary
    Dim rngDB As Range
    Dim r As Long
    Dim s As String
    
    Set wb = Application.ActiveWorkbook
    Set Dic = CreateObject("Scripting.Dictionary") ' New Scripting.Dictionary

    Dim firstAddress As String
    Dim finalrow As Long, i As Long
    Dim shtCS As Worksheet, shtFD As Worksheet, rw As Range
    Dim c As Range

    Set shtCS = wb.Sheets("Clients")
    Set shtFD = wb.Sheets("Orders")

    finalrow = shtCS.Range("A" & Rows.Count).End(xlUp).Row
    With shtCS
         vDB = .Range("M1", "M" & finalrow) 'Phone number
         Set rngDB = .Range("v1", "v" & finalrow) 'email
         vR = rngDB
    End With
    For i = 1 To UBound(vDB, 1)
        Dic.Add vDB(i, 1), i
    Next i
    With shtFD
        vPhone = .Range("c1", "d" & .Range("c" & Rows.Count).End(xlUp).Row) 'phone, email
    End With
    r = UBound(vPhone, 1)
    For i = 1 To r
        If vPhone(i, 2) <> "" Then
            s = vPhone(i, 1)
            If Dic.Exists(s) Then
                vR(Dic(s), 1) = vPhone(i, 2)
            End If
        End If
    Next i
    rngDB = vR

End Sub

Answer 2

使用 Find 进行查找

微软

• Range.Find

此页面上的两个示例即使不是不准确或更糟，至少也不清楚。

在它们上方，它声明 “LookIn、LookAt、SearchOrder 的设置， 每次使用此方法时都会保存和 MatchByte。" 然后两者都保存 示例不包含LookAt 参数xlPart（子字符串）。 它们也与您的情况不同，因为它们正在改变（替换） 循环中的值，所以迟早不会剩下什么 去寻找。

• Range.FindNext

此外，此页面上的所有三个示例都至少不清楚，如果不是不准确或更糟的话。

• 第一个与“查找页面”上的两个之一相同。
• 在第二个示例中，假设LookAt 参数为xlPart（子字符串）。如果还假设LookIn 参数是 xlValues，这是 Find 方法所必需的 未能在隐藏的行或列中找到值，第二部分 “Loop While 行”将始终为真，使其变得多余。在 另一方面，如果LookIn 参数为xlFormulas，那么 第一部分总是正确的，所以它是多余的。
• 在第三个示例中，再次假设LookAt 参数是xlPart（子字符串）。它显示了它的好处 LookIn 参数 xlFormulas 能够在隐藏行中找到或 在这种情况下，在隐藏列中。 'Loop While 的第一部分 line' 将始终为 true，因此它是多余的。

您的情况

• 以下是我将如何处理您的情况（使用Find 方法）。因为我想从第一个单元格开始“查找”，所以我使用After 参数中范围的最后一个单元格（棘手）。我使用xlFormulas 能够找到即使行或列被隐藏。然后我使用xlWhole 来查找整个字符串（而不是子字符串）。我省略了“同样重要”参数SearchOrder（在一行或一列时不需要）、SearchDirection（默认为xlNext）和MatchCase（默认为False：A=a）的参数)。
• Exit Do 用于在找到电子邮件地址时退出Do Loop。
• Source (s) 和 Destination (d) 是我更喜欢在您的情况下使用的概念。 Source 被读取，Destination 被写入。在“查找”情况下（如您的情况），Destination 也会被读取。随意更改（重命名）这些，例如如果您觉得“客户和订单概念”对您来说可能更具可读性，请改为“客户和订单概念”。
• 调整常量部分中的值。

守则

Option Explicit

Sub lookupClientEmails()
    
    ' Source
    Const sName As String = "Orders"
    Const sFirstRow As Long = 2
    Const sLookup As String = "C" ' 3
    Const sResultOffset As Long = 1 ' referring to column 'D'
    ' Destination
    Const dName As String = "Clients"
    Const dFirstRow As Long = 2
    Const dLookup As String = "M" ' 13
    Const dResult As String = "V" ' 22
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim sLastRow As Long
    sLastRow = sws.Cells(sws.Rows.Count, sLookup).End(xlUp).Row
    Dim srg As Range
    Set srg = sws.Cells(sFirstRow, sLookup).Resize(sLastRow - sFirstRow + 1)
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dLastRow As Long
    dLastRow = dws.Cells(dws.Rows.Count, dLookup).End(xlUp).Row
    ' Variables
    Dim sCell As Range
    Dim i As Long
    Dim FirstAddress As String
    ' Loop
    For i = dFirstRow To dLastRow
        Set sCell = srg.Find(dws.Cells(i, dLookup).Value, _
            srg.Cells(srg.Rows.Count), xlFormulas, xlWhole)
        If Not sCell Is Nothing Then
            FirstAddress = sCell.Address
            Do
                If sCell.Offset(, sResultOffset).Value <> "" Then
                    dws.Cells(i, dResult).Value _
                        = sCell.Offset(, sResultOffset).Value
                    Exit Do
                End If
                Set sCell = srg.FindNext(sCell)
            Loop While sCell.Address <> FirstAddress
        End If
    Next i

End Sub