VBA to Get SUMMARY of Multipple Sheet

**mag** · 12-26-2012, 02:28 PM

I need to get Sale Summary from Multiple Sheet is there any way to get Any VBA Codes ?

When i Create New Sheet that Sheet Sales Always Have to Add To Summary i Need Like that for Month 1st to 30th. Please help Me.

Please Have Look on Sample File i Attached.

Thanks
Regards
mag

**princ_wns** · 12-26-2012, 04:03 PM

Hi Mag,

Hope this will help you.

Code:

Sub GetSummary()
    
    Dim wks As Worksheet
    
    For Each wks In ThisWorkbook.Worksheets
        If wks.Name <> "Summary" Then
            With wks
                Intersect(.Range("B5").CurrentRegion, .Range("B5").CurrentRegion.Offset(1)).Copy
            End With
            With ThisWorkbook.Worksheets("Summary")
                .Range("A" & .Range("D" & Rows.Count).End(xlUp).Row + 1).PasteSpecial
                Application.CutCopyMode = False
           End With
        End If
    Next
    With ThisWorkbook.Worksheets("Summary")
        .Range("A1").Value = "Item"
        .Range("B1").Value = "Qty"
        .Range("C1").Value = "Rate"
        .Range("D1").Value = "Total"
    End With
End Sub

Regards
Prince

**mag** · 12-26-2012, 04:45 PM

Thanks For the Reply But Thats Not What Exactly i Need Please Find the attached file Result And Requirement

Thanks

**LalitPandey87** · 12-26-2012, 09:54 PM

Find solution at below mentioned link

TestC.xlsm

**mag** · 12-27-2012, 11:50 AM

Thanks Lalit For the Reply But Still Thats not result i want Please find the attached file and help me to get the result accordingly.

**Rajan_Verma** · 12-27-2012, 01:18 PM

You can use Consolidate to get it done..

Rajan.

**LalitPandey87** · 12-27-2012, 01:19 PM

Originally Posted by mag

Thanks Lalit For the Reply But Still Thats not result i want Please find the attached file and help me to get the result accordingly.

Replace previous code with this one

Code:

Option Explicit

Private Const strFindItem                   As String = "Item"
Private Const strSummarySheet               As String = "Summary"
Private Const strPvtTblName                 As String = "pvtTemp"
Private Const strPvtTblDesti                As String = "$I$1"

Sub GetSummary()
    
    Dim objWks                      As Worksheet
    Dim rngData                     As Range
    Dim varData()                   As Variant
    Dim lngCount                    As Long
    
    If Application.ScreenUpdating Then Application.ScreenUpdating = False
    
    lngCount = 0
    For Each objWks In ThisWorkbook.Worksheets
        With objWks
            If .Name <> strSummarySheet Then
                lngCount = lngCount + 1
                Set rngData = Nothing
                ReDim varData(0)
                On Error Resume Next
                Set rngData = .Cells.Find(What:=strFindItem, LookIn:=xlValues)
                Set rngData = rngData.CurrentRegion.Offset(-1)
                Set rngData = Intersect(rngData, rngData.Offset(1))
                If WorksheetFunction.Count(rngData) > 0 Then
                    If lngCount = 1 Then
                        varData = rngData.Value
                    ElseIf lngCount > 1 Then
                        Set rngData = Intersect(rngData, rngData.Offset(1))
                        varData = rngData.Value
                    End If
                End If
                On Error GoTo 0: Err.Clear
                If UBound(varData) > 0 Then
                    With ThisWorkbook.Worksheets(strSummarySheet)
                        If lngCount = 1 Then
                            .Range("A1").CurrentRegion.Clear
                            Set rngData = .Range("A1")
                        Else
                            Set rngData = .Range("A1").Cells(.Rows.Count, 1).End(xlUp).Offset(1)
                        End If
                        rngData.Resize(UBound(varData), UBound(varData, 2)).Value = varData
                    End With
                End If
            End If
        End With
    Next objWks
    
    With ThisWorkbook.Worksheets(strSummarySheet)
        varData = InsertPivot(.Range("A1").CurrentRegion)
        .Cells.ClearContents
        If Not Application.ScreenUpdating Then Application.ScreenUpdating = True
        If UBound(varData) > 0 Then
            .Range("A1").Resize(UBound(varData), UBound(varData, 2)).Value = varData
            If LCase(varData(1, 2)) = "values" Then
                .Range("A1").EntireRow.Delete
            End If
            MsgBox "Data summarized successfully.", vbInformation, "Data Summarization"
        Else
            MsgBox "No data available to summarized.", vbInformation, "Data Summarization"
        End If
    End With
    
    
    Set objWks = Nothing
    Set rngData = Nothing
    Erase varData
    lngCount = Empty
    
End Sub


Function InsertPivot(ByVal rngData As Range) As Variant

    Dim varColumnHeader()               As Variant
    Dim lngColumn                       As Long
    
    ReDim varColumnHeader(0)
    
    With ThisWorkbook.Worksheets(strSummarySheet)
        .Range(strPvtTblDesti).CurrentRegion.EntireColumn.Delete Shift:=xlToLeft
    End With
    On Error Resume Next
    varColumnHeader = rngData.Resize(1).Value
    On Error GoTo 0: Err.Clear
    If UBound(varColumnHeader) > 0 Then
        With ThisWorkbook
            Application.DisplayAlerts = False
            .PivotCaches.Create(xlDatabase, rngData).CreatePivotTable .Worksheets(strSummarySheet).Range(strPvtTblDesti), strPvtTblName
            .ShowPivotTableFieldList = True
            Application.DisplayAlerts = True
        End With
        
        With ThisWorkbook.Worksheets(strSummarySheet)
            With .PivotTables(strPvtTblName)
                For lngColumn = LBound(varColumnHeader) + 1 To UBound(varColumnHeader, 2)
                    .PivotFields(strFindItem).Orientation = xlRowField
                    .PivotFields(strFindItem).Position = 1
                    If LCase(varColumnHeader(1, lngColumn)) = "rate" Then
                        .AddDataField .PivotFields(varColumnHeader(1, lngColumn)), "_" & varColumnHeader(1, lngColumn), xlMax
                    Else
                        .AddDataField .PivotFields(varColumnHeader(1, lngColumn)), "_" & varColumnHeader(1, lngColumn), xlSum
                    End If
                Next lngColumn
            End With
            varColumnHeader = .Range(strPvtTblDesti).CurrentRegion.Value
            .Range(strPvtTblDesti).CurrentRegion.Delete Shift:=xlToLeft
            .Range(strPvtTblDesti).Resize(UBound(varColumnHeader), UBound(varColumnHeader, 2)).Value = varColumnHeader
            If LCase(varColumnHeader(1, 2)) = "values" Then
                .Range(strPvtTblDesti).Resize(rngData.Resize(1).Rows.Count, rngData.Resize(1).Columns.Count).Offset(1).Value = rngData.Resize(1).Value
            Else
                .Range(strPvtTblDesti).Resize(rngData.Resize(1).Rows.Count, rngData.Resize(1).Columns.Count).Value = rngData.Resize(1).Value
            End If
            varColumnHeader = .Range(strPvtTblDesti).CurrentRegion.Value
            .Range(strPvtTblDesti).CurrentRegion.Clear
            For lngColumn = LBound(varColumnHeader) To UBound(varColumnHeader, 2) - 1
                varColumnHeader(UBound(varColumnHeader), lngColumn) = ""
            Next lngColumn
        End With
    End If
    InsertPivot = varColumnHeader
    
    Erase varColumnHeader
    lngColumn = Empty

End Function

**mag** · 12-27-2012, 01:48 PM

Thanks Lalit

That Great if i want add new column What changes i have to Do?? when i add new row i can still get result i need get result if i add new column also Please Let Me know..

**LalitPandey87** · 12-27-2012, 02:32 PM

Originally Posted by mag

Thanks Lalit

That Great if i want add new column What changes i have to Do?? when i add new row i can still get result i need get result if i add new column also Please Let Me know..

Here is the code if column increased

Code:

Option Explicit

Private Const strPvtFirstRowVal             As String = "Values"
Private Const strFindItem                   As String = "Item"
Private Const strSummarySheet               As String = "Summary"
Private Const strSummaryDataCell            As String = "A1"
Private Const strPvtTblName                 As String = "pvtTemp"
Private Const strPvtTblDesti                As String = "A1"
Private Const strTempPvtShtName             As String = "TempSht"
Private Const strRateFieldHeader            As String = "Rate"

Sub GetSummary()
    
    Dim objWks                      As Worksheet
    Dim rngData                     As Range
    Dim varData()                   As Variant
    Dim lngCount                    As Long
    
    If Application.ScreenUpdating Then Application.ScreenUpdating = False
    
    lngCount = 0
    For Each objWks In ThisWorkbook.Worksheets
        With objWks
            If .Name <> strSummarySheet Then
                lngCount = lngCount + 1
                Set rngData = Nothing
                ReDim varData(0)
                On Error Resume Next
                Set rngData = .Cells.Find(What:=strFindItem, LookIn:=xlValues)
                Set rngData = rngData.CurrentRegion.Offset(-1)
                Set rngData = Intersect(rngData, rngData.Offset(1))
                If WorksheetFunction.Count(rngData) > 0 Then
                    If lngCount = 1 Then
                        varData = rngData.Value
                    ElseIf lngCount > 1 Then
                        Set rngData = Intersect(rngData, rngData.Offset(1))
                        varData = rngData.Value
                    End If
                End If
                On Error GoTo 0: Err.Clear
                If UBound(varData) > 0 Then
                    With ThisWorkbook.Worksheets(strSummarySheet)
                        If lngCount = 1 Then
                            .Range(strSummaryDataCell).CurrentRegion.Clear
                            Set rngData = .Range(strSummaryDataCell)
                        Else
                            Set rngData = .Range(strSummaryDataCell).Cells(.Rows.Count, 1).End(xlUp).Offset(1)
                        End If
                        rngData.Resize(UBound(varData), UBound(varData, 2)).Value = varData
                    End With
                End If
            End If
        End With
    Next objWks
    
    With ThisWorkbook.Worksheets(strSummarySheet)
        varData = InsertPivot(.Range(strSummaryDataCell).CurrentRegion)
        .Cells.ClearContents
        If UBound(varData) > 0 Then
            .Range(strSummaryDataCell).Resize(UBound(varData), UBound(varData, 2)).Value = varData
            If LCase(varData(1, 2)) = LCase(strPvtFirstRowVal) Then
                .Range(strSummaryDataCell).EntireRow.Delete
            End If
            MsgBox "Data summarized successfully.", vbInformation, "Data Summarization"
        Else
            MsgBox "No data available to summarized.", vbInformation, "Data Summarization"
        End If
    End With
    
    
    Set objWks = Nothing
    Set rngData = Nothing
    Erase varData
    lngCount = Empty
    
    If Not Application.ScreenUpdating Then Application.ScreenUpdating = True
    
End Sub


Function InsertPivot(ByVal rngData As Range) As Variant

    Dim varColumnHeader()               As Variant
    Dim lngColumn                       As Long
    Dim wksSht                          As Worksheet
    
    ReDim varColumnHeader(0)
    
    With ThisWorkbook
        On Error Resume Next
        Application.DisplayAlerts = False
        .Worksheets(strTempPvtShtName).Delete
        Application.DisplayAlerts = True
        On Error GoTo -1: Err.Clear
        Set wksSht = Sheets.Add
        wksSht.Name = strTempPvtShtName
    End With
    On Error Resume Next
    varColumnHeader = rngData.Resize(1).Value
    On Error GoTo 0: Err.Clear
    If UBound(varColumnHeader) > 0 Then
        With ThisWorkbook
            Application.DisplayAlerts = False
            .PivotCaches.Create(xlDatabase, rngData).CreatePivotTable wksSht.Range(strPvtTblDesti), strPvtTblName
            .ShowPivotTableFieldList = True
            Application.DisplayAlerts = True
        End With
        
        With wksSht
            With .PivotTables(strPvtTblName)
                For lngColumn = LBound(varColumnHeader) + 1 To UBound(varColumnHeader, 2)
                    .PivotFields(strFindItem).Orientation = xlRowField
                    .PivotFields(strFindItem).Position = 1
                    If LCase(varColumnHeader(1, lngColumn)) = LCase(strRateFieldHeader) Then
                        .AddDataField .PivotFields(varColumnHeader(1, lngColumn)), "_" & varColumnHeader(1, lngColumn), xlMax
                    Else
                        .AddDataField .PivotFields(varColumnHeader(1, lngColumn)), "_" & varColumnHeader(1, lngColumn), xlSum
                    End If
                Next lngColumn
            End With
            varColumnHeader = .Range(strPvtTblDesti).CurrentRegion.Value
            .Range(strPvtTblDesti).CurrentRegion.Delete Shift:=xlToLeft
            .Range(strPvtTblDesti).Resize(UBound(varColumnHeader), UBound(varColumnHeader, 2)).Value = varColumnHeader
            If LCase(varColumnHeader(1, 2)) = LCase(strPvtFirstRowVal) Then
                .Range(strPvtTblDesti).Resize(rngData.Resize(1).Rows.Count, rngData.Resize(1).Columns.Count).Offset(1).Value = rngData.Resize(1).Value
            Else
                .Range(strPvtTblDesti).Resize(rngData.Resize(1).Rows.Count, rngData.Resize(1).Columns.Count).Value = rngData.Resize(1).Value
            End If
            varColumnHeader = .Range(strPvtTblDesti).CurrentRegion.Value
            If LCase(varColumnHeader(1, 2)) = LCase(strPvtFirstRowVal) Then
                .Range(strPvtTblDesti).EntireRow.Delete
            End If
            varColumnHeader = .Range(strPvtTblDesti).CurrentRegion.Value
            .Range(strPvtTblDesti).CurrentRegion.Clear
            For lngColumn = LBound(varColumnHeader) To UBound(varColumnHeader, 2) - 1
                varColumnHeader(UBound(varColumnHeader), lngColumn) = ""
            Next lngColumn
            On Error Resume Next
            Application.DisplayAlerts = False
            .Delete
            Application.DisplayAlerts = True
            On Error GoTo -1: Err.Clear
        End With
    End If
    InsertPivot = varColumnHeader
    
    Erase varColumnHeader
    lngColumn = Empty
    Set wksSht = Nothing

End Function