Copy values from multiple sheets to summary sheet - excel

Question

In the image, there are some empty cells in column L,M, W:Z.
I am trying to loop through all sheets in the workbook.
Starting from Sheet1, filter out the empty "L" cells under the blue header in "A7",
copy the array of values (between A:Z or all cells with values in the row, ideally),
paste the copied array in the summary sheet,
Copy P2 for each sheet and paste the value as a separator between sheets.
Then continue a loop through the sheets.
Typically these workbooks have between 100-150 sheets.
These workbooks are generated for work, so I have adjusted the values accordingly.
South Park references everywhere is my style with VBA since nobody else sees them.
Issue: row numbers are dynamic, and I do not know how to offset from row "A7" after filtering without variation.
Sub Missing_L_Value_Summary()
Dim MyRange As Range
Dim MyCell As Range
Dim ws As Worksheet, myValue
Dim lCount As Long
Dim title As Long
Dim rng As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.Name = "Sheet1"
'Workbook.Save.Name = Range("A2") & "James Cameron"
'Range("A2").Copy
Sheets.Add.Name = "Summary"
Sheets("Summary").Select
'Range("A1").PasteSpecial
ActiveCell.Offset(2, 1).Select
Sheets("Sheet1").Select
Range("A8").Copy
Sheets("Summary").Select
ActiveCell.PasteSpecial
Range("B3").EntireColumn.AutoFit
Sheets("Sheet1").Select
Range("$A$7:$Z$7").Copy
Sheets("Summary").Select
ActiveCell.Offset(1, 0).PasteSpecial
Sheets("Sheet1").Select
For Each ws In Sheets
Range("L7").Select
With ws.Cells(7, 12).CurrentRegion
.AutoFilter Field:=12, Criteria1:="="'
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox("James Cameron doesn't do what James Cameron does for James Cameron. James Cameron does
End Sub
what James Cameron does for James Cameron!")

Answer 1

Get Filtered Rows
Option Explicit
Sub Missing_L_Value_Summary()
Const ProcName As String = "Missing_L_Value_Summary"
On Error GoTo ClearError
Dim IsSuccess As Boolean
Const sExceptionsList As String = "Summary" ' add more
Const sExceptionsDelimiter As String = ","
Const sBeforeSheetName As String = "Sheet1"
Const sfCellAddressCR As String = "L7"
Const sDateAddress As String = "P2"
Const sField As Long = 12
Const sCriteria As String = "="
Const dName As String = "Summary"
Const dfCellAddress As String = "A3"
Const dDateCol As String = "B"
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet
On Error Resume Next ' prevent error if it doesn't exist
Set dws = wb.Worksheets(dName)
On Error GoTo ClearError
If Not dws Is Nothing Then
Application.DisplayAlerts = False ' delete without confirmation
dws.Delete
Application.DisplayAlerts = True
End If
Set dws = wb.Worksheets.Add(Before:=wb.Worksheets(sBeforeSheetName))
dws.Name = dName
Dim dCell As Range: Set dCell = dws.Range(dfCellAddress)
Dim sExceptions() As String
sExceptions = Split(sExceptionsList, sExceptionsDelimiter)
Dim sws As Worksheet
Dim srg As Range
Dim svrg As Range
Dim drg As Range
Dim dData As Variant
Dim drCount As Long
Dim ErrNum As Long
For Each sws In wb.Worksheets
If IsError(Application.Match(sws.Name, sExceptions, 0)) Then
If sws.AutoFilterMode Then sws.AutoFilterMode = False
' Write date.
dCell.EntireRow.Columns(dDateCol).Value = sws.Range(sDateAddress)
Set dCell = dCell.Offset(1)
' Write data.
Set srg = sws.Range(sfCellAddressCR).CurrentRegion
On Error Resume Next
srg.AutoFilter sField, sCriteria
ErrNum = Err.Number
On Error GoTo ClearError
If ErrNum = 0 Then
On Error Resume Next
Set svrg = srg.SpecialCells(xlCellTypeVisible)
On Error GoTo ClearError
sws.AutoFilterMode = False
If Not svrg Is Nothing Then
dData = GetFilteredRows(svrg)
If Not IsEmpty(dData) Then
drCount = UBound(dData, 1)
Set drg = dCell.Resize(drCount, UBound(dData, 2))
drg.Value = dData
Set dCell = dCell.Offset(drCount)
Set svrg = Nothing
End If
End If
End If
End If
Next sws
IsSuccess = True
SafeExit:
If Application.EnableEvents = False Then
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
If IsSuccess Then
MsgBox "James Cameron doesn't do what James Cameron does " _
& "for James Cameron. James Cameron does what James Cameron does " _
& "for James Cameron!", vbInformation
Else
MsgBox "Something went wrong.", vbCritical
End If
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume SafeExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a filtered range in a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetFilteredRows( _
ByVal FilteredRange As Range) _
As Variant
Const ProcName As String = "GetFilteredRows"
On Error GoTo ClearError
Dim saCount, drCount, cCount
With FilteredRange
saCount = .Areas.Count
drCount = Intersect(.Offset(0), _
.Worksheet.Columns(.Cells(1).Column)).Cells.Count
cCount = .Areas(1).Columns.Count
End With
Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
Dim sarg As Range
Dim sData As Variant
Dim srCount As Long, sr As Long, dr As Long, c As Long
For Each sarg In FilteredRange.Areas
srCount = sarg.Rows.Count
If cCount + srCount > 2 Then
sData = sarg.Value
Else
ReDim sData(1 To 1, 1 To 1)
sData(1, 1) = sarg.Value
End If
For sr = 1 To srCount
dr = dr + 1
For c = 1 To cCount
dData(dr, c) = sData(sr, c)
Next c
Next sr
Next sarg
GetFilteredRows = dData
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function

Answer 2

i use only offset formula because if i remove lines or columns he never give error
ex: if im in cell B5 of sheet2 and want show same information from sheet1
=OFFSET(sheet1!$A$1;ROW(B5)-1;COLUMN(B5)-1)
Only cell fix are A1 sheet1