将多个工作表中的数据合并到列中关键字的一张表中

复制条件行

Option Explicit

Sub CopyCriteriaRows()
    
    ' Source
    Const sCols As String = "A:F"
    Const sfRow As Long = 2
    Const scCol As Long = 5
    Const sCriteria As String = "On Stock"
    ' Destination
    Const dName As String = "Blanco List"
    Const dFirst As String = "A2"
    ' Exceptions
    Const ExceptionsList As String = "Blanco List" ' add more
    Const ListSeparator As String = ","
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Write the names of the worksheets to be 'processed' to an array.
    Dim wsNames As Variant
    wsNames = ArrWorksheetNames(wb, ExceptionsList, ListSeparator)
    If IsEmpty(wsNames) Then Exit Sub ' no worksheet found
    
    ' Create a reference to the first destination row range.
    ' Note that the number of columns is equal in source and destination.
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim cCount As Long: cCount = dws.Columns(sCols).Columns.Count
    Dim drrg As Range: Set drrg = dws.Range(dFirst).Resize(, cCount)
    
    Dim sws As Worksheet ' Source Worksheet
    Dim srg As Range ' Source Range
    Dim sfrrg As Range ' Source First Row Range
    Dim drg As Range ' Destination Range
    
    Dim Data As Variant ' Data Array
    Dim cValue As Variant ' Current Value
    
    Dim dr As Long ' Destination Row Counter
    Dim sr As Long ' Source Row Counter
    Dim c As Long ' Column Counter
    
    For Each sws In wb.Worksheets(wsNames)
        ' Create a reference to the current Source First Row Range.
        Set sfrrg = sws.Columns(sCols).Rows(sfRow)
        Set srg = Nothing
        ' Create a reference to the current Source Range.
        Set srg = RefColumns(sfrrg)
        If Not srg Is Nothing Then ' the current Source Range is not empty
            ' Write the values from the current Source Range to the Data Array.
            Data = GetRange(srg)
            ' Write the matches to the top of the Data Array. The size
            ' of the array stays the same but 'dr' is used: to track
            ' the number of, to move, and finally, to write (to the worksheet)
            ' the 'destination' values.
            dr = 0
            For sr = 1 To UBound(Data, 1)
                cValue = Data(sr, scCol)
                If StrComp(CStr(cValue), sCriteria, vbTextCompare) = 0 Then
                    dr = dr + 1
                    For c = 1 To cCount
                        Data(dr, c) = Data(sr, c)
                    Next c
                End If
            Next sr
            If dr > 0 Then ' there have been matches
                ' Create a reference to the Destination Range.
                Set drg = drrg.Resize(dr)
                ' Write only the 'destination' values (dr) from
                ' the Data Array to the Destination Range.
                drg.Value = Data
                ' Create a reference to the next Destination First Row Range.
                Set drrg = drrg.Offset(dr)
            End If
        End If
    Next sws
    
    ' The 'Clear Range' is the range spanning
    ' from the last 'Destination First Row Range'
    ' (which was referenced, but was not written to)
    ' to the bottom-most row range of the worksheet.
    Dim crg As Range
    Set crg = drrg.Resize(dws.Rows.Count - drrg.Row + 1)
    crg.ClearContents
    
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the names of the worksheets of a workbook ('wb'),
'               that are not included in a list ('ExceptionsList'),
'               in an array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrWorksheetNames( _
    ByVal wb As Workbook, _
    Optional ByVal ExceptionsList As String = "", _
    Optional ByVal ListSeparator As String = ",", _
    Optional ByVal FirstIndex As Long = 0) _
As Variant
    If wb Is Nothing Then Exit Function
    
    Dim wsCount As Long: wsCount = wb.Worksheets.Count
    If wsCount = 0 Then Exit Function ' There could e.g. only be charts.
    
    Dim IndexDiff As Long: IndexDiff = FirstIndex - 1
    Dim LastIndex As Long: LastIndex = wsCount + IndexDiff
    Dim Arr() As String: ReDim Arr(FirstIndex To LastIndex)
    Dim n As Long: n = IndexDiff
    
    Dim ws As Worksheet
    
    If Len(ExceptionsList) = 0 Then
        For Each ws In wb.Worksheets
            n = n + 1
            Arr(n) = ws.Name
        Next ws
    Else
        Dim Exceptions() As String
        Exceptions = Split(ExceptionsList, ListSeparator)
        For Each ws In wb.Worksheets
            If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
                n = n + 1
                Arr(n) = ws.Name
            End If
        Next ws
    End If
    
    Select Case n
    Case IndexDiff
        Exit Function
    Case Is < LastIndex
        ReDim Preserve Arr(FirstIndex To n)
    End Select
    
    ArrWorksheetNames = Arr
    
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the range spanning from the first row
'               of a given range ('rg') to the row containing the bottom-most
'               non-empty cell of the given range's columns.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumns( _
    ByVal rg As Range) _
As Range
    If rg Is Nothing Then Exit Function
    
    With rg.Rows(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , xlByRows, xlPrevious)
        If lCell Is Nothing Then Exit Function ' empty range
        Set RefColumns = .Resize(lCell.Row - .Row + 1)
    End With

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a range in a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
    ByVal rg As Range) _
As Variant
    If rg Is Nothing Then Exit Function
    
    Dim rData As Variant
    If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell only
        ReDim rData(1 To 1, 1 To 1): rData(1, 1) = rg.Value
    Else
        rData = rg.Value
    End If

    GetRange = rData
End Function


' Irrelevant to the Question,
' but for a better understanding of `ArrWorksheetNames`.

Sub ArrWorksheetNamesTEST()
    
    Const ExceptionsList As String = "Sheet1,Sheet2,Sheet3,Sheet4"
    Const ListSeparator As String = ","
    Const FirstIndex As Long = 4
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim wsNames As Variant
    wsNames = ArrWorksheetNames(wb, ExceptionsList, ListSeparator, FirstIndex)
    
    If IsEmpty(wsNames) Then
        Debug.Print "No worksheets."
    Else
        Debug.Print "[" & LBound(wsNames) & "," & UBound(wsNames) & "]" _
            & vbLf & Join(wsNames, vbLf)
    End If

End Sub