Copy and paste values from multiple sheets in to summary sheet-CodePudding

As you can see 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- which is why I am trying to automate this process. Notes for those who help:

Thank you very much for your time and being so courteous! If you live in the rockies, let me buy you a beer.
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 or uses them
I am new with VBA, and chop and paste from various stack overflows on the web with prior projects to get to my end goal. I am hitting a wall pretty bad on this one, and I would greatly appreciate the help! Issues so far: row numbers are dynamic, and I cannot seem to use 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!")

CodePudding user response：

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

CodePudding user response：

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