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

Question

我有两个 sheet（“客户”、“订单”）。我想通过 phone 个数字来匹配两者。

在订单 sheet 中，我有以下 table：

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

我试图循环到我的客户列中的所有数字，在订单 sheet 中找到一个匹配项，该匹配项在侧列值中包含一封邮件。

我正在为退出循环而苦苦挣扎，因为我没有更改变量“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

已确定意图根据订单详细信息更改客户sheet的电子邮件。使用字典可以减少循环。

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

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

Above them, it states "The settings for LookIn, LookAt, SearchOrder, and MatchByte are saved each time you use this method." and then both examples do not contain the LookAt parameter xlPart (substrings). They also differ from your case in that they are changing (replacing) the value in the loop, so sooner or later there will be nothing left to find.

Range.FindNext

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

The first is the same as one of the two on the 'Find page'.

In the second example, it is assumed that the LookAt parameter is xlPart (substrings). If it is also assumed that the LookIn parameter is xlValues which is necessary for the Find method to fail to find the value in a hidden row or column, the second part of the 'Loop While line' will always be true, making it redundant. On the other hand, if the LookIn parameter would be xlFormulas then the first part would always be true, making it redundant.

In the third example, again it is assumed that the LookAt parameter is xlPart (substrings). It shows the benefit of the LookIn parameter xlFormulas being able to find in a hidden row or in this case, in a hidden column. The first part of the 'Loop While line' will always be true, making it redundant.

您的案例

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

代码

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

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

Find All Matches and copy side column's value <>""

excel

vba

loops

find

使用查找查找