VBA to Get SUMMARY of Multipple Sheet

[LalitPandey87]

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

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