前端之家

  1. 首页
  2. 问答

如果多个查找条件匹配，则在VBA中...

• 问答

我有输入和输出选项卡。

在“输入”选项卡中，我的标题位于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

我需要分别搜索Header和所有Sub-Header。

例如：在输出列B中搜索输入HDR1，但也在同一行号的列C中搜索输入SB1.1。如果找到，则将输入数据复制到输出数据列。如果不是，请在此示例中的C列中搜索第二个子标题（即SB2.1）。

这里的事情是我不知道任何标题有多少个子标题。可能是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
  

我的问题是这部分：如何创建正确的“查找”循环。这部分使我很吃力，即使在SO中，我也找不到互联网上任何地方的正确答案！ 

Set Brange = wsO.Range("F").Find(FirstBcellText,xlValues,xlWhole)
Set cRange = wsO.Range("G").Find(wsI.Range(",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
pf030232 回答：如果多个查找条件匹配，则在VBA中...

您可能会使用如下所示的内容。

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
excelvba
本文链接：https://www.f2er.com/3155273.html

大家都在问