匹配多个条件并返回多个值

Question

我有两个电子表格（ wb和wbtemp ）； 两者都有一个用于位置的列和一个用于要素类型的列。 在VBA中，我想找到第二张纸上的所有行，其中两列与第一张纸上一行的两列相同，并获取由行号/索引组成的列表或范围。

然后，我想使用该范围从不同的列中提取值，并在其中找到最高的对象，但是我认为，如果我可以对此范围进行排序，那么我将能够做到这一点。

Dim wb As Workbook
Dim ws As Worksheet
Dim Features() As Variant
Dim Activity() As Variant
Dim Benthic As Variant
Dim wbtemp As Workbook
Dim BenSenFeatures() As Variant
Dim BenSenActivity() As Variant
Dim LR As Long
Dim LC As Long
Dim r As Long
Dim c As Long
Dim WhatToFind1 As Variant
Dim WhatToFind2 As Variant
Dim rngFound1 As Range
Dim rngFound2 As Range
Dim rng1 As Variant
Dim rng2 As Variant
Dim rngFound As Range
Dim iLoop As Long
Dim colFound As Range

Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet

Features = ws.Range("B:C").Value
Activity = ws.Rows(1).Value

Benthic = InputBox("Filename goes here...")
Set wbtemp = Workbooks.Open(Benthic, True, True)

With wbtemp
    BenSenFeatures = .Sheets(1).Range("A:B").Value
    BenSenActivity = .Sheets(1).Rows(1).Value
End With

LR = ws.Range("C" & Rows.Count).End(xlUp).Row
LC = ws.Cells(1, Columns.Count).End(xlToLeft).Column

For r = 3 To LR

    If Not IsEmpty(Features(r, 2)) Then
        If IsInArray(Features(r, 2), BenSenFeatures, 2) Then
        'If WorksheetFunction.Match(Features(r, 2), BenSenFeatures(0, 2), 0) Then   <---I tried to use the arrays originally
            WhatToFind1 = Features(r, 1)
            WhatToFind2 = Features(r, 2)
            Set rngFound1 = wbtemp.Sheets(1).Columns(1).Cells(wbtemp.Sheets(1).Columns(1).Cells.Count)
            Set rngFound2 = wbtemp.Sheets(1).Columns(2).Cells(wbtemp.Sheets(1).Columns(2).Cells.Count)
            For iLoop = 1 To WorksheetFunction.CountIf(wbtemp.Sheets(1).Columns(1), WhatToFind1)
                Set rngFound1 = wbtemp.Sheets(1).Columns(1).Cells.Find(WhatToFind1, After:=rngFound1)
                rng1(iLoop) = rngFound1.Row
            'WorksheetFunction.Index(wbtemp.Sheets(1).Range("A:B").Value,_
               WorksheetFunction.Match(WhatToFind1 & WhatToFind2,_
               wbtemp.Sheets(1).Columns(1) & wbtemp.Sheets(1).Columns(2),_
               0), 1)     <---originally tried to use match to search for the multiple criteria but couldn't find a way to create a list of indices
                Set rngFound2 = wbtemp.Sheets(1).Columns(2).Cells.Find(WhatToFind2, After:=rngFound2)
                rng2(iLoop) = rngFound2.Row
            Next iLoop
            For Each cell In rng1
                If Not Application.CountIf(rng2, cell.Value) = 0 Then
                    rngFound.Cells(Cells(Rows.Count, 1).End(xlUp) + 1) = cell.Value
                End If
            Next

我最初尝试使用.Match查找多个条件，但是我不知道如何从中创建一系列索引。 然后，我尝试使用.Find创建两个索引列表，但我不知道如何使它工作。 我不断

类型不匹配

错误。

我意识到这听起来令人困惑，所以让我知道是否需要澄清。

Answer 1

这样的事情应该为您工作。 为了清楚起见，我尝试对代码进行注释。

Sub tgr()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rData As Range
    Dim wbTemp As Workbook
    Dim wsTemp As Worksheet
    Dim rTempData As Range
    Dim aData() As Variant
    Dim aTempData() As Variant
    Dim aResults() As Variant
    Dim lNumResults As Long
    Dim DataIndex As Long, TempIndex As Long, ResultIndex As Long, j As Long
    Dim sCritRange1 As String, sCritRange2 As String
    Dim sCriteria1 As String, sCriteria2 As String

    Set wb = ActiveWorkbook

    'Adjust these two as necessary
    Set ws = wb.Sheets(1)
    Set rData = ws.Range("B3", ws.Cells(ws.Rows.Count, "B").End(xlUp))

    'Select wbTemp file
    On Error Resume Next
    Set wbTemp = Workbooks.Open(Application.GetOpenFilename("Excel Files, *.xls*"))
    On Error GoTo 0
    If wbTemp Is Nothing Then Exit Sub  'Pressed cancel

    'Adjust these two as necessary
    Set wsTemp = wbTemp.Sheets(1)
    Set rTempData = wsTemp.Range("A1", wsTemp.Cells(wsTemp.Rows.Count, "A").End(xlUp))

    sCritRange1 = rTempData.EntireColumn.Address(external:=True)
    sCritRange2 = rTempData.Offset(, 1).EntireColumn.Address(external:=True)
    sCriteria1 = rData.Address(external:=True)
    sCriteria2 = rData.Offset(, 1).Address(external:=True)
    lNumResults = Evaluate("SUMPRODUCT(COUNTIFS(" & sCritRange1 & "," & sCriteria1 & "," & sCritRange2 & "," & sCriteria2 & "))")
    If lNumResults = 0 Then Exit Sub    'No matches
    ReDim aResults(1 To lNumResults, 1 To 3)
    aData = rData.Resize(, 2).Value
    aTempData = rTempData.Resize(, 2).Value

    'Loop through both data ranges
    For DataIndex = LBound(aData, 1) To UBound(aData, 1)
        For TempIndex = LBound(aTempData, 1) To UBound(aTempData, 1)

            'Find where both criteria matches
            If aTempData(TempIndex, 1) = aData(DataIndex, 1) And aTempData(TempIndex, 2) = aData(DataIndex, 2) Then
                'Match found, add to results and collect the row index
                ResultIndex = ResultIndex + 1
                aResults(ResultIndex, 1) = aData(DataIndex, 1)
                aResults(ResultIndex, 2) = aData(DataIndex, 2)
                aResults(ResultIndex, 3) = "Row: " & TempIndex + rTempData.Row - 1   'This is the row index from wsTemp of the found match
            End If

        Next TempIndex
    Next DataIndex

    'Row index results gathered
    'Do what you want with the results
    'In this example it is just providing msgboxes displaying the results
    For ResultIndex = LBound(aResults, 1) To UBound(aResults, 1)
        MsgBox "Location: " & aResults(ResultIndex, 1) & Chr(10) & _
               "Feature:  " & aResults(ResultIndex, 2) & Chr(10) & _
               "RowIndex: " & aResults(ResultIndex, 3)
    Next ResultIndex

    'Close wbTemp
    wbTemp.Close

End Sub

Answer 2

我对tigeravatar的答案做了一些小的修改，以使其与我的数据配合使用：

• 主要创建一个循环遍历wb每一行的循环，以便与CountIfs一起使用的条件是单个值而不是值的范围。
• 我换了Evaluate("SUMPRODUCT(COUNTIFS(" & sCritRange1 & "," & sCriteria1 & "," & sCritRange2 & "," & sCriteria2 & "))")为Application.WorksheetFunction.CountIfs(Range(sCritRange1), Range(sCriteria1).Value, Range(sCritRange2), Range(sCriteria2).Value)

我要感谢tigeravatar的帮助。

LR = ws.Range("C" & Rows.Count).End(xlUp).Row
LC = ws.Cells(1, Columns.Count).End(xlToLeft).Column   

For r = 3 To LR

sCritRange1 = rTempData.EntireColumn.Address(external:=True)
sCritRange2 = rTempData.Offset(, 1).EntireColumn.Address(external:=True)
sCriteria1 = rData(r, 1).Address(external:=True)
sCriteria2 = rData(r, 1).Offset(, 1).Address(external:=True)
lNumResults = Application.WorksheetFunction.CountIfs(Range(sCritRange1), Range(sCriteria1).Value, Range(sCritRange2), Range(sCriteria2).Value)
If lNumResults = 0 Then Exit Sub    'No matches
ReDim aResults(1 To lNumResults, 1 To 3)
aData = rData(r, 1).Resize(, 2).Value
aTempData = rTempData.Resize(, 2).Value

'Loop through both data ranges
For DataIndex = LBound(aData, 1) To UBound(aData, 1)
    For TempIndex = LBound(aTempData, 1) To UBound(aTempData, 1)

        'Find where both criteria matches
        If Not IsEmpty(aTempData(TempIndex, 1)) Then
            If aTempData(TempIndex, 1) = aData(DataIndex, 1) And aTempData(TempIndex, 2) = aData(DataIndex, 2) Then
                'Match found, add to results and collect the row index
                ResultIndex = ResultIndex + 1
                aResults(ResultIndex, 1) = aData(DataIndex, 1)
                aResults(ResultIndex, 2) = aData(DataIndex, 2)
                aResults(ResultIndex, 3) = "Row: " & TempIndex + rTempData.Row - 1   'This is the row index from wsTemp of the found match
            End If
        End If

    Next TempIndex
Next DataIndex



Next r