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