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

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

使用查找查找

微软

• 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 行”的第一部分将始终为真，使其变得多余。

你的案例

• 以下是我将如何处理您的案例（使用Find方法）。 由于我想从第一个单元格开始“查找”，因此我在After参数中使用范围的最后一个单元格（棘手）。 我使用xlFormulas能够找到即使行或列被隐藏。 然后我使用xlWhole来查找整个字符串（而不是子字符串）。 我省略了“同样重要”的参数 arguments SearchOrder （一行或一列时不需要）、 SearchDirection （默认为xlNext ）和MatchCase （默认为False ： A=a ）。
• Exit Do用于在找到 email 地址时退出Do Loop 。
• Source (s) 和Destination (d) 是我更喜欢在您的情况下使用的概念。 写入Destination时读取Source 。 在“查找”情况下（如您的情况），还会读取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