如何基于多个制表符相关值进行嵌套搜索？

Question

我有三个工作表，即帐户，JEExtracts和详细信息摘录。

我想基于Account WS中唯一的值进行搜索，并从JEExtracts中找到所有匹配项，然后基于找到的所有匹配值，获取与该行相对应的另一个单元格的值，并从Detail提取WS中搜索所有实例。

当我这样做时，第一次迭代就可以了。在第二次迭代中，搜索字符串丢失其值。它以未定义的错误对象结束。

Sub FilterAccount()

    Dim c As Range
    Dim searchRng As Range
    Dim searchRng2 As Range
    Dim LastAcc As Long
    Dim LastRowJE As Long
    Dim LastRowDE As Long
    Dim fAddress
    Dim fAddress2

    LastAcc = Sheets("Accounts").Cells(2, 1).End(xlDown).Row
    LastRowJE = Sheets("JournalExtract").Cells(2, 2).End(xlDown).Row
    LastRowDE = Sheets("DetailExtract").Cells(2, 10).End(xlDown).Row

    LastAcc = LastAcc - 1
    LastRowJE = LastRowJE - 1
    LastRowDE = LastRowDE - 1

    ACRow = 2
    ACCol = 1
    JERow = 2
    JECol = 7
    DERow = 2
    DECol = 10

    Worksheets("Accounts").Activate
    Application.ScreenUpdating = False

    'Loop through cells to do the lookup based on value on a particular column of worksheet Accounts
    For Each c In Sheets("Accounts").Range(Cells(ACRow, ACCol), Cells(LastAcc, ACCol))
        'MsgBox (c.Value)

        If IsEmpty(c) = True Then Exit For       'If there is no value found in the cell then exit from the process
        If IsEmpty(c) = False Then               'If there is value found in the cell then search the same value in JournalExtract

            Worksheets("JournalExtract").Activate

            With Sheets("JournalExtract").Range(Cells(JERow, JECol), Cells(LastRowJE, JECol)) 'Using the cells looking up resource name in pivot tab
                Set searchRng = .Find(What:=c.Value) 'Find it

                If Not searchRng Is Nothing Then 'If we find a value
                    fAddress = searchRng.Address 'Set the address to compare

                    Do
                        searchRng.Offset(0, 0).Cells.Interior.Color = RGB(255, 0, 0)
                        Worksheets("DetailExtract").Activate

                        'Using the value from worksheet JournalExtract looking up value in DetailExtract
                        With Sheets("DetailExtract").Range(Cells(DERow, DECol), Cells(LastRowDE, DECol))

                            Set searchRng2 = .Find(What:=searchRng.Offset(0, 4)) 'Find it
                            If Not searchRng2 Is Nothing Then
                                fAddress2 = searchRng2.Address

                                Do
                                    searchRng2.Offset(0, 0).Cells.Interior.Color = RGB(255, 255, 0)
                                    Set searchRng2 = .FindNext(searchRng2)
                                Loop While Not searchRng2 Is Nothing And searchRng2.Address <> fAddress2

                            End If
                            Set searchRng2 = Nothing

                        End With

                        Worksheets("JournalExtract").Activate
                        Set searchRng = .FindNext(searchRng) 'Doesn't get value in 2nd iteration

                    Loop While Not searchRng Is Nothing And searchRng.Address <> fAddress 'Here error is thrown - Object value not set.

                End If

            End With

        End If
        Set searchRng = Nothing
    Next

    Application.ScreenUpdating = True

End Sub

Answer 1

一对Find / FindNext对只能一次使用。如果您尝试使用第一个“ Find / FindNext”中的值嵌套嵌套的“ Find / FindNext”，则第一个将被删除，并由第二个替换。您需要一种替代的嵌套查找方法，也可以隔离每个进程。

希望它更接近您的需求，但我并未对其进行全面测试。它根据第一个Find / FindNext对的结果建立一个并集，然后循环通过范围的并集来处理第二个Find / FindNext对。

Option Explicit

Sub FilterAccount()


    Dim c As Range, s As Range
    Dim searchRng As Range, foundRng As Range
    Dim searchRng2 As Range
    Dim LastAcc As Long, LastRowJE As Long, LastRowDE As Long
    Dim ACRow As Long, ACCol As Long, JERow As Long, JECol As Long, DERow As Long, DECol As Long
    Dim fAddress As String, fAddress2 As String

    LastAcc = Worksheets("Accounts").Cells(Rows.Count, "A").End(xlUp).Row - 1
    LastRowJE = Worksheets("JournalExtract").Cells(Rows.Count, "B").End(xlUp).Row - 1
    LastRowDE = Worksheets("DetailExtract").Cells(Rows.Count, "J").End(xlUp).Row - 1

    ACRow = 2
    ACCol = 1
    JERow = 2
    JECol = 7
    DERow = 2
    DECol = 10

    With Worksheets("Accounts")

        'Loop through cells to do the lookup based on value on a particular column of worksheet Accounts
        For Each c In .Range(.Cells(ACRow, ACCol), .Cells(LastAcc, ACCol))

            'If there is no value found in the cell then exit from the process
            If IsEmpty(c) Then
                Exit For
            Else

                With Worksheets("JournalExtract")

                    'Using the cells looking up resource name in pivot tab
                    With .Range(.Cells(JERow, JECol), .Cells(LastRowJE, JECol))

                        Set searchRng = .Find(What:=c.Value) 'Find it

                        'If we find a value
                        If Not searchRng Is Nothing Then
                            fAddress = searchRng.Address 'Set the address to compare
                            Set foundRng = searchRng
                            'collect all the searchRngs into a union
                            Do
                                Set foundRng = Union(foundRng, searchRng)
                                Set searchRng = .FindNext(after:=searchRng)
                            Loop While searchRng.Address <> fAddress

                            foundRng.Cells.Interior.Color = RGB(255, 0, 0)

                            'now on to the second search
                            'cycle through the union
                            For Each s In foundRng

                                With Worksheets("DetailExtract")
                                    'Using the value from worksheet JournalExtract looking up value in DetailExtract
                                    With .Range(.Cells(DERow, DECol), .Cells(LastRowDE, DECol))

                                        Set searchRng2 = .Find(What:=c.Offset(0, 4)) 'Find it

                                        If Not searchRng2 Is Nothing Then

                                            fAddress2 = searchRng2.Address

                                            Do
                                                searchRng2.Offset(0, 0).Cells.Interior.Color = RGB(255, 255, 0)
                                                Set searchRng2 = .FindNext(searchRng2)
                                            Loop While searchRng2.Address <> fAddress2

                                        End If
                                    End With
                                End With
                            Next s
                        End If
                    End With
                End With
            End If

        Next c
    End With

End Sub

Answer 2

您可以使用SQL查询数据。请注意，我将Accounts更改为Account。 Sample workbook。

Sub FindValues()

    Dim c%, sql$, conn_string$
    Dim rs As Object
    Dim wksOutput As Worksheet

    conn_string = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                  "Data Source=" & ThisWorkbook.FullName & ";" & _
                  "Extended Properties=""Excel 12.0"";"

    Set rs = CreateObject("ADODB.Recordset")
    rs.CursorLocation = adUseClient

    sql$ = "SELECT A.Account, J.[Link ID], DE.[Values] " & _
           "FROM ([Accounts$] AS A " & _
           "INNER JOIN [JEExtracts$] AS J " & _
                "ON A.Account = J.Account) " & _
            "INNER JOIN ['Detail Extracts$'] AS DE " & _
                "ON J.[Link ID] = DE.[Link ID];"

    rs.Open sql, conn_string, adOpenForwardOnly, adLockReadOnly

    If rs.RecordCount > 0 Then
        Set wksOutput = Sheets.Add(After:=Sheets(Sheets.Count))
        wksOutput.Name = "output"
        With wksOutput
            '// Output headers
            For c = 0 To rs.Fields.Count - 1
                .Cells(1, c + 1) = rs.Fields(c).Name
            Next
            .Range("A2").CopyFromRecordset rs
        End With
    Else
        MsgBox "No records were found.", vbExclamation
    End If

    rs.Close
    Set rs = Nothing

End Sub