在两个工作簿中搜索匹配项，如果找到，则复制信息。

Question

此代码用于更新源文档中的客户端信息，以便从我可以随时从客户端服务器提取的列表中进行邮件合并。

我在这段代码接近尾声时遇到了一个障碍。目前它所经历的过程如下：

1. 用户选择需要更新的合并文档。
2. 用户选择具有更新地址的列表。
3. 代码步进合并文档，获取公司名称，然后
4. 在第二个文档中搜索该公司，从列表中复制地址信息，以及
5. 将其粘贴到合并文档中公司名称旁边，然后
6. 从合并文档中的下一个公司名称开始。

我目前被困在第四步和第五步之间。

下面是我试图调整以搜索源代码工作簿的一些代码，但我认为这是行不通的--我需要将找到的术语粘贴到宏工作簿中，而且在这里我对VBA的知识有一个空白。

如果有必要的话，我可以发布我的完整代码，但是我不想马上把所有的东西都扔进去。

提前感谢！

Set sourcewkb = ActiveWorkbook

Dim rnnng As Range
Dim searchfor As String
Debug.Print celld
searchfor = celld

Set rnnng = Selection.Find(what:=searchfor)
If rnnng Is Nothing Then
    Debug.Print "yes"
    Else
    Debug.Print "no"

End If

编辑

我尝试了注释中的一些建议，但我遇到了一个问题，即selection.find是否确实存在这个变量。我想不知怎么在这两本练习本里都找到了？

完整的代码(在编辑代码时，为了方便起见，有些部分被标记为注释，它们通常不是我关心的部分)：

更新后的完整代码：

Sub addressfinder()

    Dim rCell
    Dim rRng As Range
    Dim aftercomma As String
    Dim celld As String
    Dim s As String
    Dim indexOfThey As Integer
    Dim mrcell As Range
    Dim alreadyfilled As Boolean
    Dim nocompany As Boolean
    Dim sourcewkb


    Dim updaterwkb
    Dim fd As FileDialog
    Dim cellstocopy As Range
    Dim cellstopaste As Range
    Dim x As Byte



    'select updater workbook
    updaterwkb = "L:\Admin\Corporate Books\2015\letter macro\Annual Consent Letter Macro.xlsm"

    'this is the finished updater workbook selecter.
'    Set fd = Application.FileDialog(msoFileDialogFilePicker)
'
'
'    Dim vrtselecteditem As Variant
'    MsgBox "select the Annual Consent Letter Macro workbook"
'
'    With fd
'        If .Show = -1 Then
'            For Each vrtselecteditem In .SelectedItems
'
'
'            updaterwkb = vrtselecteditem
'            Debug.Print updaterwkb
'            Next vrtselecteditem
'            Else
'        End If
'  End With



    'select file of addresses
    sourcewkb = "L:\Admin\Corporate Books\2015\letter macro\source workbook_sample.xlsx"

    'this is the finished source select code

'    Dim lngcount As Long
'    If MsgBox("Have you gotten this year's updated contact list exported from Time Matters or Outlook?", vbYesNo, "confirm") = vbYes Then
'        If MsgBox("Is the information in that excel workbook formatted per the instructions?", vbYesNo, "Confirm") = vbYes Then
'            MsgBox "Good. Select that workbook now."
'        Else
'            MsgBox "Format the workbook before trying to update the update list"
'        End If
'    Else
'        MsgBox "Have someone export you a client list with company name, client name, and client address"
'
'    End If
'
'
'    With Application.FileDialog(msoFileDialogOpen)
'        .AllowMultiSelect = False
'        .Show
'        For lngcount = 1 To .SelectedItems.Count
'            Debug.Print .SelectedItems(lngcount)
'            sourcewkb = .SelectedItems(lngcount)
'
'        Next lngcount
'    End With
'

Workbooks.Open (sourcewkb)

'start the code

        Set updaterwkb = ActiveWorkbook


    Set rRng = Sheet1.Range("a2:A500")

    For Each rCell In rRng.Cells
        'boolean resets
        alreadyfilled = False
        nocompany = False

        'setting up the step-through
        s = rCell.Value
        indexOfThey = InStr(1, s, ",")
        aftercomma = Right(s, Len(s) - indexOfThey + 1)
        celld = Left(s, Len(s) - Len(aftercomma))
        Debug.Print rCell.Value, "celld", celld
        Debug.Print "address", rCell.Address


        'setting up already filled check
        Set mrcell = rCell.Offset(rowoffset:=0, ColumnOffset:=6)
         Debug.Print "mrcell", mrcell.Value

        If Len(rCell.Formula) = 0 Then
           Debug.Print "company cell sure looks empty"
           nocompany = True
        End If

        If Len(mrcell.Formula) > 0 Then
           Debug.Print "mrcell has content"
           alreadyfilled = True
           Else: Debug.Print "mrcell has no content"
        End If

        If alreadyfilled = False Then
                If nocompany = False Then
                        'the code for copying stuff

                        'open source document
                        'search source document for contents of celld
                        'if contents of celld are found, copy everything to the right of the cell in which
                            'they were found and paste it horizontally starting at mrcell
                        'if not, messagebox "address for 'celld' not found

'Set sourcewkb = ActiveWorkbook
'
'Dim rnnng As Range
'Dim searchfor As String
'Debug.Print celld
'searchfor = celld
'
'Set rnnng = Selection.Find(what:=searchfor)
'If Not rnnng Is Nothing Then
'    Debug.Print "yes"
'    Else
'    Debug.Print "no"
'
'End If




Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim company As String
Dim lastRow As Long
Dim rng As Variant
Dim llc As String
Dim inc As String
Dim searchfor As String


Set wb1 = ThisWorkbook
Set wb2 = Workbooks("source workbook_sample.xlsx") 'change workbook name
Set ws1 = ThisWorkbook.Worksheets(1) 'change worksheet #
Set ws2 = wb2.Worksheets(1) 'change worksheet #
llc = ",LLC"
inc = ",INC."

'lastRow = ws1.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

With ws1

    For i = 1 To 500

        If Cells(i, 1).Value = searchfor Then
            company = .Cells(i, 1)

            With ws2
                'change range as necessary
                Set f = .Range("A1:D100").Find(company, LookIn:=xlValues)
                If Not f Is Nothing Then
                    Debug.Print searcfor
                    fRow = f.Row
                    rng = .Range("B" & fRow & ":D" & fRow)
                    ws1.Range("B" & i & ":D" & i) = rng
                End If
            End With
        End If
    Next

End With











'
                    Else
                    Debug.Print "skipped cuz there ain't no company"
               End If
            Else
           Debug.Print "skipped cuz it's filled"
      End If
''
'



        Debug.Print "next"

























    Next rCell



End Sub

固定代码：

With ws1

    For i = 1 To 500

        If Cells(i, 1).Value = searchfor Then
            company = .Cells(i, 1)

            With ws2
                'change range as necessary
                Set f = .Range("A1:D100").Find(company, LookIn:=xlValues)
                If Not f Is Nothing Then
                    Debug.Print searcfor
                    fRow = f.Row
                    rng = .Range("B" & fRow & ":D" & fRow)
                    ws1.Range("B" & i & ":D" & i) = rng
                End If
            End With
        End If
    Next

End With

Answer 1

Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim company As String
Dim lastRow As Long
Dim rng As Variant
Dim llc As String
Dim inc As String
Dim searchfor As String

Set wb1 = ThisWorkbook 'Annual Consent Letter Macro
Set wb2 = Workbooks("source workbook_sample.xlsx")
Set ws1 = ThisWorkbook.Worksheets(1)
Set ws2 = wb2.Worksheets(1)
llc = ",LLC"
inc = ",INC."

With ws1

For i = 1 To 500

    If Cells(i, 1).Value = searchfor Then
        company = .Cells(i, 1)

        With ws2
            'change range as necessary
            Set f = .Range("A1:A500").Find(company, LookIn:=xlValues)
            If Not f Is Nothing Then
                Debug.Print searcfor
                fRow = f.Row
                rng = .Range("B" & fRow & ":D" & fRow)
                ws1.Range("B" & i & ":D" & i) = rng
            End If
        End With
    End If
Next

End With

End Sub