VBA EXCEL 在列中的文本字符串与不同工作表上的不同列中搜索匹配项。 如果找到匹配项，复制并粘贴

Question

我正在拼命地学习 Excel 足以自己做到这一点，但我无法弄清楚。 我真的很感激你能给我的任何帮助。 我之前发布的信息还不够多，所以这是包含更多信息的转贴。

一个文档粘贴在单元格 A9 中。

它用数据行填充它下面的每个单元格，最多 A200。

数据行如下所示：

192800002001 19280 G RG474 56 DAY PMI COMPLETE
19280A001001 19280 G CB359 AN/PRC-152A 56 DAY PMI
19280A005001 19280 G CB360 AN/PRC-152A 56 DAY PMI

我需要该程序在 A 列中的每个单元格中搜索看起来像“RG474”或“CB359”的单词，并在同一本书的不同工作表上的参考表中搜索。 参考表上的表是这样的

RG474 | xxx474 0 | 0 | IN RACK | AF6
CB915 | xxx359 0 | 0 | IN RACK | AF6

对于找到的每个匹配项，它将参考表中的行粘贴到粘贴文档旁边的匹配行（LQ 列）。

我在网上找到了一些我试过无济于事的代码，我试过的两件事在这里：

    Dim lastRw1, lastRw2, nxtRw, m

    'Determine last row with data, refrene
    lastRw1 = Sheets("380 Refrence").Range("A" & Rows.Count).End(xlUp).Row
    'Determine last row with data, Import
    lastRw2 = Sheets("analyser").Range("A" & Rows.Count).End(xlUp).Row
    'Loop through Import, Column A
    For nxtRw = 9 To lastRw2
        'Search Sheet1 Column C for value from Import
        With Sheets("380 Refrence").Range("A9:A" & lastRw1)
            Set m = .Find(Sheets("analyser").Range("A" & nxtRw), LookIn:=xlValues, lookat:=xlWhole)
            'Copy Import row if match is found
            If Not m Is Nothing Then
                Sheets("analyser").Range("A" & nxtRw & ":F" & nxtRw).Copy _
                Destination:=Sheets("380 Refrence").Range("L" & m.Row)
            End If
        End With
    Next
End Sub

Sub CopyImportData()

    Dim lastRw1, lastRw2, nxtRw, m
    Dim code As String, RefRow As Integer
    Dim rowValues

    'Determine last row with data, 380 Refrencerene
    lastRw1 = Sheets("380 Refrence").Range("A" & Rows.Count).End(xlUp).Row

    'Determine last row with data, Import
    lastRw2 = Sheets("analyser").Range("A" & Rows.Count).End(xlUp).Row

    For Row = 9 To lastRw2
        With Sheets("analyser").Cell(Row, 1)
            'meet the laziest error handling ever to find your 380 Refrenceerence value
            code = WorksheetFunction.Mid(.Value, WorksheetFunction.IfError(WorksheetFunction.IfError(WorksheetFunction.Search("CB??? ", .Value), WorksheetFunction.Search("RG??? ", .Value)), 1), 5)
        End With

        With Sheets("380 Refrence")
            'Use Excel Match to find the 380 Refrenceerence row, which is offset by 8
            'I swear I'll stop using iferror
    380         RefrenceRow = WorksheetFunction.IfError(WorksheetFunction.Match(code, .Range("A9:A" & lastRw1), 0) + 8, -1)

            '-1 is our safeword, copy the range
            If RefRow <> -1 Then
                .Range("A" & RefRow & ":F" & RefRow).Copy Destination:=Worksheets("analyser").Range("L" & Row)
            End If
        End With
    Next Row
End Sub

我没有写这些，也没有完全理解它们，但我确实明白了它的要点。

这是工作簿的一个非常精简的副本： https://drive.google.com/open?id=1qCz8DUCz6tA5-KbxKDnvRq_KiBDkl4W5

Answer 1

这对我有用 - 我跳过了一些“查找最后一个单元格”位，因此您需要对此进行调整

Sub Tester()

    Dim c As Range, v, f
    Dim ws380 As Worksheet, wsAn As Worksheet

    Set ws380 = ThisWorkbook.Sheets("380 Reference")
    Set wsAn = ThisWorkbook.Sheets("analyser")

    For Each c In wsAn.Range("A1:A50") 'for example
        If Len(c.Value) > 0 Then
            v = GetMatch(c.Value)
            Debug.Print c.Address, v

            If Len(v) > 0 Then
                'got a value - look it up...
                Set f = ws380.Range("A9:A5000").Find(v, lookat:=xlWhole, _
                                                    lookin:=xlValues)
                If Not f Is Nothing Then
                    f.Resize(1, 6).Copy c.EntireRow.Cells(1, "L") 'copy found row
                End If
            End If

        End If
    Next c

End Sub


Function GetMatch(txt As String)

    Dim re As Object, allMatches, m

    Set re = CreateObject("VBScript.RegExp")
    'looking for two upper-case letters then 3 digits, or 3 letters plus 2 digits
    ' with a word boundary on each end
    re.Pattern = "(\b([A-Z]{2}\d{3}\b)|(\b[A-Z]{3}\d{2})\b)"
    re.ignorecase = False
    re.Global = True

    Set allMatches = re.Execute(txt)
    For Each m In allMatches
        GetMatch = m.Value
        Exit For
    Next m

End Function

这是一个很好的 vbscript 正则表达式参考：

https://docs.microsoft.com/en-us/previous-versions/windows/internet-explorer/ie-developer/scripting-articles/ms974570(v=msdn.10)?redirectedfrom=MSDN