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