Forum Discussion

calof1's avatar
calof1
Iron Contributor
Jul 22, 2020
Solved

Help with Macro to collate data

Hi,   I have a spreadsheet i will use to record our submissions for Class Actions. Each tab is for one Class action or stock.   As there is many tabs i wish to have a summary tab for those which ...
  • Subodh_Tiwari_sktneer's avatar
    Jul 23, 2020

    calof1 

     

    You may try something like this....

    Sub CreateSummary()
    Dim wsSummary       As Worksheet
    Dim ws              As Worksheet
    Dim dlr             As Long
    Dim lr              As Long
    
    Application.ScreenUpdating = False
    
    Set wsSummary = Worksheets("Summary - Active")
    wsSummary.Range("A1").CurrentRegion.Offset(1).Clear
    
    For Each ws In ThisWorkbook.Worksheets
        If Not ws.Name Like "List*" And Not ws.Name Like "Summary*" Then
            ws.AutoFilterMode = False
            lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
            dlr = wsSummary.Cells(Rows.Count, 1).End(xlUp).Row + 1
            With ws.Range("A1").CurrentRegion
                .AutoFilter field:=9, Criteria1:="Open"
                
                If .SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then
                    ws.Range("B2:B" & lr).SpecialCells(xlCellTypeVisible).Copy wsSummary.Range("A" & dlr)
                    ws.Range("A2:A" & lr).SpecialCells(xlCellTypeVisible).Copy wsSummary.Range("B" & dlr)
                    ws.Range("C2:C" & lr).SpecialCells(xlCellTypeVisible).Copy wsSummary.Range("C" & dlr)
                    ws.Range("D2:D" & lr).SpecialCells(xlCellTypeVisible).Copy wsSummary.Range("D" & dlr)
                    ws.Range("G2:G" & lr).SpecialCells(xlCellTypeVisible).Copy wsSummary.Range("E" & dlr)
                    ws.Range("H2:H" & lr).SpecialCells(xlCellTypeVisible).Copy wsSummary.Range("F" & dlr)
                    ws.Range("J2:J" & lr).SpecialCells(xlCellTypeVisible).Copy wsSummary.Range("G" & dlr)
                End If
                
            End With
            ws.AutoFilterMode = False
        End If
    Next ws
    dlr = wsSummary.Cells(Rows.Count, 1).End(xlUp).Row + 2
    wsSummary.Range("B2:B" & dlr).Borders(xlEdgeRight).Weight = xlThin
    wsSummary.Range("G2:B" & dlr).Borders(xlEdgeRight).Weight = xlThick
    wsSummary.Sort.SortFields.Clear
    wsSummary.Range("A1").CurrentRegion.Sort key1:=wsSummary.Range("A2"), order1:=xlAscending, Header:=xlYes
    Application.ScreenUpdating = True
    End Sub

    In the attached, you will find a button called "Create Summary" on Summary Tab, you may click this button to run the macro to create the desired summary.

     

     

Resources