根据单元格值复制/粘贴列范围

Question

I have an extensive workbook with around 500 custom named worksheets that have been created by a macro that has manipulated data from a core dataset. All worksheets follow an identical format.

Within the range QG27:SO27 on every one of these ~500 worksheets there is a formula that shows "TRUE" if all the above cells meet a certain criteria, otherwise they are blank

My challenge is to collate the "TRUE" data to a separate sheet named "COLLATED TRUE VALUES". By scanning through QG27:SO27 on each worksheet, if a cell in QG27:SO27 contains "TRUE" then copy that column from row 1:27 and paste to C2 of sheet named "COLLATED TRUE VALUES" and copy/paste the sheet name it was extracted from into C1. Each additional "TRUE" encountered will copy/paste the same corresponding data to the next column in the "COLLATED TRUE VALUES" sheet and continue through all worksheets

I have considered a loop through the range that may contain "TRUE" and step through each of the 500 sheets but his would be a slow process and I expect to need to reuse this type of scenario with many other workbooks.

I would like some help creating a macro that can collate the required date in the most efficient way

Answer 1

Copy Columns of a Range With Condition

Option Explicit

Sub CollateTrueValues()
    
    ' Define constants.
    ' Source
    Const srgAddress As String = "QG1:SO27"
    Const sBoolean As Boolean = True
    ' Destination
    Const dName As String = "COLLATED TRUE VALUES"
    Const dFirstCellAddress As String = "C1"
    
    ' Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    ' Reference the destination worksheet ('dws').
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    ' Reference the destination first cell ('dfCell').
    Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
    
    ' Write the number of rows and columns to variables ('rCount', 'cCount').
    Dim rCount As Long
    Dim cCount As Long
    With dws.Range(srgAddress)
        rCount = .Rows.Count
        cCount = .Columns.Count
    End With
    
    ' Declare additional variables.
    Dim sws As Worksheet
    Dim srg As Range
    Dim sValue As Variant
    Dim Data As Variant
    Dim sName As String
    Dim r As Long
    Dim sc As Long
    Dim dc As Long
    
    ' Loop...
    For Each sws In wb.Worksheets
        ' Check if it's not the destination worksheet.
        If Not sws Is dws Then
            ' Write the source worksheet name to a variable ('sName').
            sName = sws.Name
            ' Write the source data to a 2D one-based array ('Data').
            Data = sws.Range(srgAddress).Value
            ' Write the matching data to the left 'dc' columns of the array.
            For sc = 1 To cCount
                sValue = Data(rCount, sc)
                If VarType(sValue) = vbBoolean Then
                    If sValue = sBoolean Then
                        dc = dc + 1
                        For r = 1 To rCount
                            Data(r, dc) = Data(r, sc)
                        Next r
                    'Else ' is not a match (True), do nothing
                    End If
                'Else ' is not a boolean; do nothing
                End If
            Next sc
            ' Write the matching data to the destination worksheet.
            If dc > 0 Then
                With dfCell.Resize(, dc)
                    .Value = sName ' write worksheet name
                    .Offset(1).Resize(rCount).Value = Data ' write data
                End With
                Set dfCell = dfCell.Offset(, dc) ' next first destination cell
                dc = 0
            'Else ' no matching (True) values; do nothing
            End If
        'Else ' it's the destination worksheet; do nothing
        End If
    Next sws
    
    ' Clear to the right.
    dfCell.Resize(rCount + 1, dws.Columns.Count - dfCell.Column + 1).Clear
    
    ' Inform.
    MsgBox "True values collated.", vbInformation
    
End Sub