Если несколько условий поиска совпадают, то ... в VBA

Question

У меня есть вкладки ввода и вывода.

На вкладке «Вход» у меня есть заголовки в столбце B и подзаголовки в столбце C, как показано ниже:

 A   B       C       D      
    HDR1
           SB1.1     Data1
           SB2.1     Data2
    HDR2
           SB2.1     Data3
           SB2.2     Data4
           SB2.3     Data5

И на вкладке «Вывод» у меня есть полный список, как показано ниже:

 A   B       C       D      
    HDR1   SB1.1
    HDR1   SB2.1     

    HDR2   SB2.1     
    HDR2   SB2.2     
    HDR2   SB2.3

Мне нужно найти заголовок и все его подзаголовки соответственно.

Например: поиск входного HDR1 в выходном столбце B, но также поиск входного SB1.1 в том же самомстолбец номера строки C. Если найдено, скопируйте столбец Входные данные в Выходные данные. Если нет, ищите второй подзаголовок (который является SB2.1) в столбце C в этом примере.

Дело в том, что я не знаю, сколько подзаголовков имеет какой-либо заголовок. Это может быть 1 или 5. Это все в порядке, я создал свои циклы для этого. Мой вопрос: как я могу добавить несколько условий поиска в этом цикле.

Sub Macro1()

'Call screenupdatingfalse
Dim wsO As Worksheet, wsI As Worksheet
Set wsI = Sheet2 'wsI is Input Sheet
Set wsO = Sheet1 'wsO is Output sheet
Dim RowLastB As Long, rowlastC As Long, FirstBcellRow As Long, FirstBcellText As String, OutputNewRowQty As Long, i As Long, x As Long, beginBcol As Long

'Ниже я нахожу последние строки таблицы ввода для определения конца моих петель.

    RowLastB = wsI.Cells(Rows.Count, "B").End(xlUp).Row
    rowlastC = wsI.Cells(Rows.Count, "C").End(xlUp).Row

' Ниже яначиная мои циклы с первого заголовка в столбце B. Затем находим следующий заголовок, затем ищем, сколько подзаголовков имеет каждый заголовок.

beginBcol = 1
For i = beginBcol To RowLastB
wsI.Activate
FirstBcellRow = wsI.Range("B" & i).End(xlDown).Row
FirstBcellText = wsI.Range("B" & i).End(xlDown).Text

'FirstCcellRow = wsI.Range("C" & i).End(xlDown).Row


StartCopyRow = FirstBcellRow

i = FirstBcellRow
If i = RowLastB Then
OutputNewRowQty = (rowlastC - RowLastB)
Exit For
Else
SecondBcellRow = wsI.Range("B" & i).End(xlDown).Row
OutputNewRowQty = (SecondBcellRow - FirstBcellRow) - 1
'that amount of row to be added to Output

wsO.Activate
wsO.AutoFilter.ShowAllData
On Error GoTo below

Мой вопрос состоит в следующем: какМогу ли я создать правильный цикл поиска. Эта часть съедает мой мозг, и я нигде не мог найти правильный ответ в Интернете, даже в ТАК !!

Set Brange = wsO.Range("F").Find(FirstBcellText, , xlValues, xlWhole)
Set cRange = wsO.Range("G").Find(wsI.Range(", , xlValues, xlWhole)

OutputRowNo = ActiveCell.Row

x = 1
Do Until x = OutputNewRowQty + 1
ActiveCell.Offset(1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrAbove
ActiveCell.EntireRow.Copy
ActiveCell.Offset(1).EntireRow.PasteSpecial xlPasteFormats
x = x + 1
Application.CutCopyMode = False
Loop

copyloop = 1
Do Until copyloop = OutputNewRowQty + 1

InputCopyCell = (StartCopyRow + 1)
wsI.Range("A" & InputCopyCell).Copy
wsO.Range("I" & (OutputRowNo + 1)).PasteSpecial Paste:=xlPasteValues

wsI.Range("C" & InputCopyCell).Copy
wsO.Range("J" & (OutputRowNo + 1)).PasteSpecial Paste:=xlPasteValues

wsI.Range("L" & InputCopyCell).Copy
wsO.Range("K" & (OutputRowNo + 1)).PasteSpecial Paste:=xlPasteValues
wsO.Range("K" & (OutputRowNo + 1)).NumberFormat = "$#,##0.00"

copyloop = copyloop + 1
StartCopyRow = StartCopyRow + 1
OutputRowNo = OutputRowNo + 1
Application.CutCopyMode = False
Loop

beginBcol = FirstBcellRow
End If
below:
Next
'Call screenupdatingon

End Sub

Answer 1

Возможно, вы могли бы использовать что-то вроде ниже.

Public Sub demo()
Dim wksInp As Worksheet: Set wksInp = ThisWorkbook.Worksheets("Input")
Dim wksOut As Worksheet: Set wksOut = ThisWorkbook.Worksheets("Output")
Dim lngLastRow As Long, i As Long
Dim rgRef As Range

'\\ Find Last Row on output sheet
lngLastRow = wksOut.Range("B" & wksOut.Rows.Count).End(xlUp).Row
For i = 2 To lngLastRow
    If Len(wksOut.Range("B" & i).Value) > 0 Then '\\ Check Non-Blank Cell in Column B
        '\\ See if the range exists in Input sheet
        Set rgRef = wksInp.Range("B:B").Find(wksOut.Range("B" & i).Value, , , xlWhole)
        If Not rgRef Is Nothing Then
            '\\ Now that we have found a suitable range in column B lets loop through all sub-headings in col c.
            j = 0
            Do While wksInp.Cells(rgRef.Row + 1 + j, rgRef.Column).Value = ""
                If rgRef.Offset(1 + j, 1).Value = wksOut.Range("C" & i).Value Then
                    wksOut.Range("D" & i).Value = rgRef.Offset(1 + j, 2).Value
                    Exit Do '\\Match found so we exit Do loop
                End If
                j = j + 1
            Loop
        End If
    End If
Next i

End Sub