Поиск значения / строки и дополнительных окончаний в другом листе

Question

Я хочу использовать каждое значение / строку в определенном столбце (A1, A2, A3 ...) на листе 1 для поиска определенного диапазона на листе 2 только для этого значения / строки и (!) С дополнительными окончаниями.

Пример. Используйте в рабочем листе 1 A1 = K-1234 и найдите в определенном диапазоне в рабочем листе 2 строку K-1234 и комбинации K-1234 с / x, / y, / z.Всякий раз, когда вы найдете такую ​​комбинацию, скопируйте всю строку из рабочего листа 2 в новый рабочий лист 3.

Использование столбца A в рабочем листе 1:

worksheet 1    

A

A1    = K-1234
A2    = Y-1234
A3    = RP-78
…
A1000 = Z/34-1

Поиск в листе 2 в диапазоне B1: E3 для A1, A1 / x, A1 / y и A1 / z:

worksheet 2

A     B      C     D     E

GHJ   A1/x   456   G5G   F1-1
FF-   A1     23-A  TTR   BV1
8/a   A1/z   bnR   34-1  bn/1

Так должен выглядеть лист 3 после использования A1из таблицы 1 для поиска в таблице 2:

worksheet 3

A     B     C      D      E 

FF-   A1    23-A   TTR   BV1
GHJ   A1/x  456    G5G    F1-1
8/a   A1/z  bnR    34-1   bn/1

или с записью A1:

worksheet 3

A     B          C      D      E 

FF-   K-1234     23-A   TTR   BV1
GHJ   K-1234/x   456    G5G    F1-1
8/a   K-1234/z   bnR    34-1   bn/1

(A1 / y не существует)

Продолжите с A2, A2 / x, A2 / y и A2 / z и т. Д. До конца столбца (например, A1000).

Надеюсь, я смог бы достаточно объяснить проблему,Я был бы очень благодарен за любое предложение.

Answer 1

Вы можете попробовать:

Option Explicit

Sub CopyYes()

    Dim i As Long, LastRow1 As Long, LastRow3 As Long
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim rngToSearch As Range, rngFound As Range

    With ThisWorkbook
        Set ws1 = .Worksheets("Sheet1")
        Set ws2 = .Worksheets("Sheet2")
        Set ws3 = .Worksheets("Sheet3")
    End With

    Set rngToSearch = ws2.Range("B1:E3")

    With ws1

        LastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row

        For i = 1 To LastRow1

            Set rngFound = rngToSearch.Find(.Range("A" & i).Value & "*", LookIn:=xlValues)

            If Not rngFound Is Nothing Then

                LastRow3 = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).Row

                If LastRow3 = 1 And ws3.Range("A1").Value = "" Then
                    LastRow3 = 1
                Else
                    LastRow3 = LastRow3 + 1
                End If

                ws2.Range("B" & rngFound.Row & ":E" & rngFound.Row).Copy
                ws3.Range("A" & LastRow3).PasteSpecial Paste:=xlPasteValues

            End If

        Next i

    End With

End Sub