Copy/Paste column range based on cell value - excel

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