Sub MoveDataToDifferentSheetViaArrays()
'
Application.ScreenUpdating = False ' Turn ScreenUpdating off
Application.Calculation = xlCalculationManual ' Turn Calculations off
'
Dim Column_A_Slot As Long
Dim DestinationArrayColumn As Long, DestinationArrayRow As Long, DestinationNextBlankRow As Long
Dim DataStartRow As Long
Dim TargetColumnNumber As Long
Dim RowsToDelete As String
Dim SourceArray As Variant
Dim DestinationArray() As Variant
Dim wsSource As Worksheet, wsDestination As Worksheet
'
Set wsSource = Sheets("GSC") ' <--- Set this to the proper sheet name
Set wsDestination = Sheets("Term Report") ' <--- Set this to the proper sheet name
DataStartRow = 4 ' <--- Set this to the starting row of data
TargetColumnNumber = 1 ' <--- Set this to the column # you are checking
'
With wsSource.Range("A" & DataStartRow).CurrentRegion ' Source sheet data range
SourceArray = .Value ' Load Source sheet data into SourceArray
'
For Column_A_Slot = 1 To UBound(SourceArray, 1) ' Loop for column A
If SourceArray(Column_A_Slot, TargetColumnNumber) = "T" Then ' If cell in column A = 'T' then ...
DestinationArrayColumn = DestinationArrayColumn + 1 ' increment DestinationArrayColumn
'
ReDim Preserve DestinationArray(1 To UBound(SourceArray, 2), 1 To DestinationArrayColumn) ' Redim DestinationArray keeping current values
'
For DestinationArrayRow = 1 To UBound(DestinationArray, 1)
DestinationArray(DestinationArrayRow, DestinationArrayColumn) = SourceArray(Column_A_Slot, DestinationArrayRow) ' Save the row containing
' ' 'T' into DestinationArray
Next
'
RowsToDelete = RowsToDelete & Column_A_Slot + DataStartRow - 1 & ":" & Column_A_Slot + DataStartRow - 1 & "," ' Save row to delete into string
'
If Len(RowsToDelete) > 240 Then ' If Length of RowsToDelete string > 240 then ...
RowsToDelete = Left(RowsToDelete, Len(RowsToDelete) - 1) ' Remove the the trailing comma at the end of the string
wsSource.Range(RowsToDelete).Delete ' Delete the saved Rows To Delete thus far
RowsToDelete = vbNullString ' Clear the RowsToDelete string
End If
End If
Next
'
End With
With wsDestination ' With the Destination sheet ...
DestinationNextBlankRow = .Range("B" & Rows.Count).End(xlUp).Row + 1 ' Save next blank row available in Destination sheet
'
' Display Moved rows from Source sheet in the Destination sheet
.Range("A" & DestinationNextBlankRow).Resize(UBound(DestinationArray, 2), UBound(DestinationArray, 1)) = Application.Transpose(DestinationArray)
'
.Columns.AutoFit ' Adjust column sizes to fit the Moved rows data
End With
'
RowsToDelete = Left(RowsToDelete, Len(RowsToDelete) - 1) ' Remove the the trailing comma at the end of the string
'
wsSource.Range(RowsToDelete).Delete ' Delete any remaining saved Rows To Delete
'
Application.Calculation = xlCalculationAutomatic ' Turn Calculations back on
Application.ScreenUpdating = True ' Turn ScreenUpdating back on
End Sub
