Question

我是VBA的新手并且正在努力为此找到解决方案，但在这里找不到答案。

我有一个大型数据库，每天都在继续增长。该数据库由2张纸组成。表1用于捕获从A列到BF列的数据和跨度。表2只是一个收集点，填充了从表1中收集数据的公式。我没有创建这个工作簿/数据库，在我看来设计不是很好，但这是我必须要处理的;并且改变它不是一个真正的选择。

我需要做什么：我需要创建第3张（已创建工作表），以生成以下复杂搜索...

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

我需要从搜索中收到4件事。

名称在搜索区域中显示的总次数（列AO到AX）。
名称在4个列中显示的总次数和在其他4个列中分别显示的总次数（4列为＆＃34; Pass＆＃34; 4个类别，4个为＆＃34;失败＆＃34;在相同的4个类别中）。
名称在8列中的每一列中出现的总次数
我能够使用countifs
（这是我不能做的）。我需要从名称出现的每一行中的3个完全不同的列中获取信息。

例如：如果名称出现在AO和AQ列中，但出现在不同的行上（很可能会出现）我需要从列A，B和C中获取名称出现的行的信息并复制＆amp;将该信息粘贴到“计数”下的第3页上。信息。

我可以通过使用隐藏在工作表1上的countifs函数来完成1,2和3.函数的结果通过使用= Sheet1！（单元格引用）转移到工作表3。我希望我输入正确的内容。 countifs函数引用表3中的单元格。 = COUNTIFS（Sheet1！AU17：AU2500，Sheet3！A1）。这允许我计算列AU是否具有我在第3页上的A1中键入的任何实例。通过使用此公式创建8列然后将结果传输到表3，我可以捕获初始数据。

当然，大老板想要在A，B和C列中找到这些名称出现的任何行的信息。因为＆＃34; Charlie＆＃34;可能会出现在8列中的任何一列以及当前超过2000行的任何列中，并且可能会出现多次，很明显VBA是我最好的解决方案，但对于VBA来说，我很难找到合适的组合代码和变量。

Answer 1

开始使用：这是一个通用的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.Rows中的每个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

VBAExcel

1 个答案: