VBA to Get SUMMARY of Multipple Sheet

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

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

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


Thanks

Find solution at below mentioned link

Attachment 533

:cheers:

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.

You can use Consolidate to get it done..

Rajan.

Quote:

---

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

---

:cheers:

Thanks Lalit :cheers: 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..

Quote:

---

Originally Posted by mag

Thanks Lalit :cheers: 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

---

:cheers:

Thanks Lalit That Works Fine :cheerio: