VBAExcel中的复杂搜索和返回函数

我是VBA新手，正在努力寻找解决方案，但在这里找不到答案

我有一个每天都在增长的大型数据库。数据库由两张表组成。表1用于捕获A列到BF列的数据和跨度。表2仅仅是一个收集点，其中充满了从表1收集数据的公式。我没有创建这个工作簿/数据库，我认为它设计得不是很好，但我必须使用它；而改变它并不是一个真正的选择

我需要做的是： 我需要创建第三张工作表（已创建工作表），该工作表将生成以下复杂搜索

我需要1个单元格作为输入名称的入口点。我需要在数据库中搜索AO到AX列中该名称的每个实例，从第一个条目（第17行）到最后一个条目（记住每天有20到40个新条目，因此它必须能够增长）。这是最简单的部分

我需要从我的搜索中收到4件东西

名称在搜索区域中出现的总次数（列AO到AX）

名称在其中4列中出现的总次数以及在其他4列中单独出现的总次数（4个类别中的4列为“通过”，4个类别中的4列为“失败”）

名称出现在8列中每列的总次数
我可以用countifs做这个

（这是我不能做的）。我需要从名称出现的每一行的3个完全不同的列中获取信息 例如：如果名称出现在列AO和AQ中，但在不同的行上（很可能会出现） 我需要从A、B和C列中获取名称所在行的信息，并将该信息复制粘贴到“计数”信息下方的第3页

我能够通过使用表1中隐藏的countifs函数来完成1、2和3。使用=Sheet1！将功能结果转入表3！（单元格引用）。我希望我打对了。countifs函数引用表3中的单元格。即=国家（表1！AU17:AU2500，表3！A1）。这允许我计算列AU是否有我在第3页A1中键入的任何内容的实例。通过使用此公式创建8列，然后将结果传输到第3页，我可以捕获初始数据

---

现在，大老板当然希望在A、B和C列中找到这些名字出现的任何行的信息。由于“Charlie”可能出现在8列中的任何一列和当前超过2000行的任何一行中，并且可能出现多次，因此VBA显然是我的最佳解决方案，但作为VBA新手，我正在努力找到代码和变量的正确组合

开始：这里是一个通用的findall函数，您可以使用它查找搜索范围内的所有单元格：

Function FindAll(What, _
    Optional SearchWhat As Variant, _
    Optional LookIn, _
    Optional LookAt, _
    Optional SearchOrder, _
    Optional SearchDirection As XlSearchDirection = xlNext, _
    Optional MatchCase As Boolean = False, _
    Optional MatchByte, _
    Optional SearchFormat) As Range

    'LookIn can be xlValues or xlFormulas, _
     LookAt can be xlWhole or xlPart, _
     SearchOrder can be xlByRows or xlByColumns, _
     SearchDirection can be xlNext, xlPrevious, _
     MatchCase, MatchByte, and SearchFormat can be True or False. _
     Before using SearchFormat = True, specify the appropriate settings for the Application.FindFormat _
     object; e.g. Application.FindFormat.NumberFormat = "General;-General;""-"""

    Dim SrcRange As Range
    If IsMissing(SearchWhat) Then
        Set SrcRange = ActiveSheet.UsedRange
    ElseIf TypeOf SearchWhat Is Range Then
        Set SrcRange = IIf(SearchWhat.Cells.Count = 1, SearchWhat.Parent.UsedRange, SearchWhat)
    ElseIf TypeOf SearchWhat Is Worksheet Then
        Set SrcRange = SearchWhat.UsedRange
    Else: SrcRange = ActiveSheet.UsedRange
    End If
    If SrcRange Is Nothing Then Exit Function

    'get the first matching cell in the range first
    With SrcRange.Areas(SrcRange.Areas.Count)
        Dim FirstCell As Range: Set FirstCell = .Cells(.Cells.Count)
    End With

    Dim CurrRange As Range: Set CurrRange = SrcRange.Find(What:=What, After:=FirstCell, LookIn:=LookIn, LookAt:=LookAt, _
        SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)

    If Not CurrRange Is Nothing Then
        Set FindAll = CurrRange
        Do
            Set CurrRange = SrcRange.Find(What:=What, After:=CurrRange, LookIn:=LookIn, LookAt:=LookAt, _
            SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)
            If CurrRange Is Nothing Then Exit Do
            If Application.Intersect(FindAll, CurrRange) Is Nothing Then
                Set FindAll = Application.Union(FindAll, CurrRange)
            Else: Exit Do
            End If
        Loop
    End If
End Function

找到范围后，您可以循环遍历范围中的每一行（例如Rng.行中的每一rw），并将A、B和C列中的数据提取到目标工作表

******编辑******

所以我想我会把代码放在一起，因为提取这些数据有点困难。我认为以下几点应该对你有用

目前，在第3页的“A1”中输入搜索词，它将使用同一页第2行之后的数据填充B:D列

Sub ExtractData()
    Dim wsSrc As Worksheet: Set wsSrc = Worksheets("Sheet1")
    Dim wsDest As Worksheet: Set wsDest = Worksheets("Sheet3")

    Dim LastRow As Long, RowCounter As Long
    Dim SearchRange As Range, FoundRange As Range, rw As Range
    Dim Val As String: Val = wsDest.Range("A1")

    With wsSrc
        LastRow = .UsedRange.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Set SearchRange = .Range("AO17", .Cells(LastRow, "AX")) 'AO-AX
        Set FoundRange = FindAll(Val, SearchRange)
    End With

    'Clear Destination Sheet (except header row)
    With wsDest
        On Error Resume Next
        Application.Intersect(wsDest.UsedRange, wsDest.UsedRange.Offset(1, 0)).ClearContents
        On Error GoTo 0
    End With

    ' Copy Data
    RowCounter = 2
    Set FoundRange = Union(FoundRange, FoundRange.EntireRow.Rows) 'Expand Range to entire rows of Range
    For Each rw In FoundRange.Rows
        wsDest.Cells(RowCounter, 2) = wsSrc.Cells(rw.Row, 1)
        wsDest.Cells(RowCounter, 3) = wsSrc.Cells(rw.Row, 2)
        wsDest.Cells(RowCounter, 4) = wsSrc.Cells(rw.Row, 3)
        RowCounter = RowCounter + 1
    Next rw

End Sub

Function FindAll(What, _
    Optional SearchWhat As Variant, _
    Optional LookIn, _
    Optional LookAt, _
    Optional SearchOrder, _
    Optional SearchDirection As XlSearchDirection = xlNext, _
    Optional MatchCase As Boolean = False, _
    Optional MatchByte, _
    Optional SearchFormat) As Range

    'LookIn can be xlValues or xlFormulas, _
     LookAt can be xlWhole or xlPart, _
     SearchOrder can be xlByRows or xlByColumns, _
     SearchDirection can be xlNext, xlPrevious, _
     MatchCase, MatchByte, and SearchFormat can be True or False. _
     Before using SearchFormat = True, specify the appropriate settings for the Application.FindFormat _
     object; e.g. Application.FindFormat.NumberFormat = "General;-General;""-"""

    Dim SrcRange As Range
    If IsMissing(SearchWhat) Then
        Set SrcRange = ActiveSheet.UsedRange
    ElseIf TypeOf SearchWhat Is Range Then
        Set SrcRange = IIf(SearchWhat.Cells.Count = 1, SearchWhat.Parent.UsedRange, SearchWhat)
    ElseIf TypeOf SearchWhat Is Worksheet Then
        Set SrcRange = SearchWhat.UsedRange
    Else: SrcRange = ActiveSheet.UsedRange
    End If
    If SrcRange Is Nothing Then Exit Function

    'get the first matching cell in the range first
    With SrcRange.Areas(SrcRange.Areas.Count)
        Dim FirstCell As Range: Set FirstCell = .Cells(.Cells.Count)
    End With

    Dim CurrRange As Range: Set CurrRange = SrcRange.Find(What:=What, After:=FirstCell, LookIn:=LookIn, LookAt:=LookAt, _
        SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)

    If Not CurrRange Is Nothing Then
        Set FindAll = CurrRange
        Do
            Set CurrRange = SrcRange.Find(What:=What, After:=CurrRange, LookIn:=LookIn, LookAt:=LookAt, _
            SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)
            If CurrRange Is Nothing Then Exit Do
            If Application.Intersect(FindAll, CurrRange) Is Nothing Then
                Set FindAll = Application.Union(FindAll, CurrRange)
            Else: Exit Do
            End If
        Loop
    End If
End Function

---

开始：这里是一个通用的findall函数，可用于查找搜索范围内的所有单元格：

Function FindAll(What, _
    Optional SearchWhat As Variant, _
    Optional LookIn, _
    Optional LookAt, _
    Optional SearchOrder, _
    Optional SearchDirection As XlSearchDirection = xlNext, _
    Optional MatchCase As Boolean = False, _
    Optional MatchByte, _
    Optional SearchFormat) As Range

    'LookIn can be xlValues or xlFormulas, _
     LookAt can be xlWhole or xlPart, _
     SearchOrder can be xlByRows or xlByColumns, _
     SearchDirection can be xlNext, xlPrevious, _
     MatchCase, MatchByte, and SearchFormat can be True or False. _
     Before using SearchFormat = True, specify the appropriate settings for the Application.FindFormat _
     object; e.g. Application.FindFormat.NumberFormat = "General;-General;""-"""

    Dim SrcRange As Range
    If IsMissing(SearchWhat) Then
        Set SrcRange = ActiveSheet.UsedRange
    ElseIf TypeOf SearchWhat Is Range Then
        Set SrcRange = IIf(SearchWhat.Cells.Count = 1, SearchWhat.Parent.UsedRange, SearchWhat)
    ElseIf TypeOf SearchWhat Is Worksheet Then
        Set SrcRange = SearchWhat.UsedRange
    Else: SrcRange = ActiveSheet.UsedRange
    End If
    If SrcRange Is Nothing Then Exit Function

    'get the first matching cell in the range first
    With SrcRange.Areas(SrcRange.Areas.Count)
        Dim FirstCell As Range: Set FirstCell = .Cells(.Cells.Count)
    End With

    Dim CurrRange As Range: Set CurrRange = SrcRange.Find(What:=What, After:=FirstCell, LookIn:=LookIn, LookAt:=LookAt, _
        SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)

    If Not CurrRange Is Nothing Then
        Set FindAll = CurrRange
        Do
            Set CurrRange = SrcRange.Find(What:=What, After:=CurrRange, LookIn:=LookIn, LookAt:=LookAt, _
            SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)
            If CurrRange Is Nothing Then Exit Do
            If Application.Intersect(FindAll, CurrRange) Is Nothing Then
                Set FindAll = Application.Union(FindAll, CurrRange)
            Else: Exit Do
            End If
        Loop
    End If
End Function

找到范围后，您可以循环遍历范围中的每一行（例如Rng.行中的每一rw），并将A、B和C列中的数据提取到目标工作表

******编辑******

所以我想我会把代码放在一起，因为提取这些数据有点困难。我认为以下几点应该对你有用

目前，在第3页的“A1”中输入搜索词，它将使用同一页第2行之后的数据填充B:D列

Sub ExtractData()
    Dim wsSrc As Worksheet: Set wsSrc = Worksheets("Sheet1")
    Dim wsDest As Worksheet: Set wsDest = Worksheets("Sheet3")

    Dim LastRow As Long, RowCounter As Long
    Dim SearchRange As Range, FoundRange As Range, rw As Range
    Dim Val As String: Val = wsDest.Range("A1")

    With wsSrc
        LastRow = .UsedRange.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Set SearchRange = .Range("AO17", .Cells(LastRow, "AX")) 'AO-AX
        Set FoundRange = FindAll(Val, SearchRange)
    End With

    'Clear Destination Sheet (except header row)
    With wsDest
        On Error Resume Next
        Application.Intersect(wsDest.UsedRange, wsDest.UsedRange.Offset(1, 0)).ClearContents
        On Error GoTo 0
    End With

    ' Copy Data
    RowCounter = 2
    Set FoundRange = Union(FoundRange, FoundRange.EntireRow.Rows) 'Expand Range to entire rows of Range
    For Each rw In FoundRange.Rows
        wsDest.Cells(RowCounter, 2) = wsSrc.Cells(rw.Row, 1)
        wsDest.Cells(RowCounter, 3) = wsSrc.Cells(rw.Row, 2)
        wsDest.Cells(RowCounter, 4) = wsSrc.Cells(rw.Row, 3)
        RowCounter = RowCounter + 1
    Next rw

End Sub

Function FindAll(What, _
    Optional SearchWhat As Variant, _
    Optional LookIn, _
    Optional LookAt, _
    Optional SearchOrder, _
    Optional SearchDirection As XlSearchDirection = xlNext, _
    Optional MatchCase As Boolean = False, _
    Optional MatchByte, _
    Optional SearchFormat) As Range

    'LookIn can be xlValues or xlFormulas, _
     LookAt can be xlWhole or xlPart, _
     SearchOrder can be xlByRows or xlByColumns, _
     SearchDirection can be xlNext, xlPrevious, _
     MatchCase, MatchByte, and SearchFormat can be True or False. _
     Before using SearchFormat = True, specify the appropriate settings for the Application.FindFormat _
     object; e.g. Application.FindFormat.NumberFormat = "General;-General;""-"""

    Dim SrcRange As Range
    If IsMissing(SearchWhat) Then
        Set SrcRange = ActiveSheet.UsedRange
    ElseIf TypeOf SearchWhat Is Range Then
        Set SrcRange = IIf(SearchWhat.Cells.Count = 1, SearchWhat.Parent.UsedRange, SearchWhat)
    ElseIf TypeOf SearchWhat Is Worksheet Then
        Set SrcRange = SearchWhat.UsedRange
    Else: SrcRange = ActiveSheet.UsedRange
    End If
    If SrcRange Is Nothing Then Exit Function

    'get the first matching cell in the range first
    With SrcRange.Areas(SrcRange.Areas.Count)
        Dim FirstCell As Range: Set FirstCell = .Cells(.Cells.Count)
    End With

    Dim CurrRange As Range: Set CurrRange = SrcRange.Find(What:=What, After:=FirstCell, LookIn:=LookIn, LookAt:=LookAt, _
        SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)

    If Not CurrRange Is Nothing Then
        Set FindAll = CurrRange
        Do
            Set CurrRange = SrcRange.Find(What:=What, After:=CurrRange, LookIn:=LookIn, LookAt:=LookAt, _
            SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)
            If CurrRange Is Nothing Then Exit Do
            If Application.Intersect(FindAll, CurrRange) Is Nothing Then
                Set FindAll = Application.Union(FindAll, CurrRange)
            Else: Exit Do
            End If
        Loop
    End If
End Function

---

欢迎来到StackOverflow。请注意，这不是免费的代码编写服务。然而，我们渴望帮助其他程序员（和有抱负的人）编写他们自己的代码。请阅读上的帮助主题。您可能还想在这样做的同时获得一枚徽章。之后，请使用您迄今为止编写的VBA代码更新您的问题，以便完成您希望完成的任务。我们会在这里等你。准备好帮助您完成代码了吗。@拉尔夫。谢谢你的评论。我认为我在我的问题上做得相当好。我实际上没有任何关于这个问题的代码，因为我昨天刚开始学习VBA，我迷路了。我已经学会了如何选择单元格和更改工作表等基本知识，但这仍然是我无法理解的。我会继续努力，希望能写一些代码来做点什么，但我知道你们不是来为大家写代码的。如果我的问题表明这是我的目标，我深表歉意。欢迎来到StackOverflow。请注意，这不是免费的代码编写服务。然而，我们渴望帮助其他程序员（和有抱负的人）编写他们自己的代码。请阅读上的帮助主题。您可能还想在这样做的同时获得一枚徽章。之后，请使用您迄今为止编写的VBA代码更新您的问题，以便完成您希望完成的任务。我们会在这里等你。准备好帮助您完成代码了吗。@拉尔夫。谢谢你的评论。我认为我在我的问题上做得相当好。我实际上没有任何关于这个问题的代码，因为我昨天刚开始学习VBA，我迷路了。我已经学会了如何选择单元格和更改工作表等基本知识，但这仍然是我无法理解的。我会继续努力，希望能写一些代码来做点什么，但我知道你们不是来为大家写代码的。我的ap