Page 1 of 2 12 LastLast
Results 1 to 10 of 11

Thread: VBA to Get SUMMARY of Multipple Sheet

  1. #1
    Junior Member
    Join Date
    Dec 2012
    Posts
    16
    Rep Power
    0

    Question 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
    Attached Files Attached Files

  2. #2
    Member
    Join Date
    Nov 2011
    Posts
    41
    Rep Power
    0
    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

  3. #3
    Junior Member
    Join Date
    Dec 2012
    Posts
    16
    Rep Power
    0
    Thanks For the Reply But Thats Not What Exactly i Need Please Find the attached file Result And Requirement


    Thanks
    Attached Files Attached Files

  4. #4
    Senior Member LalitPandey87's Avatar
    Join Date
    Sep 2011
    Posts
    222
    Rep Power
    14
    Find solution at below mentioned link

    TestC.xlsm

    Last edited by LalitPandey87; 12-27-2012 at 08:23 AM.

  5. #5
    Junior Member
    Join Date
    Dec 2012
    Posts
    16
    Rep Power
    0
    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.
    Attached Files Attached Files

  6. #6
    Member Rajan_Verma's Avatar
    Join Date
    Sep 2011
    Posts
    81
    Rep Power
    14
    You can use Consolidate to get it done..

    Rajan.

  7. #7
    Senior Member LalitPandey87's Avatar
    Join Date
    Sep 2011
    Posts
    222
    Rep Power
    14
    Quote Originally Posted by mag View Post
    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

  8. #8
    Junior Member
    Join Date
    Dec 2012
    Posts
    16
    Rep Power
    0
    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..

  9. #9
    Senior Member LalitPandey87's Avatar
    Join Date
    Sep 2011
    Posts
    222
    Rep Power
    14
    Quote Originally Posted by mag View Post
    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

  10. #10
    Junior Member
    Join Date
    Dec 2012
    Posts
    16
    Rep Power
    0
    Thanks Lalit That Works Fine

Similar Threads

  1. Replies: 1
    Last Post: 06-12-2013, 07:42 PM
  2. VBA to Get Sales SUMMARY of Multipple Sheet
    By mag in forum Excel Help
    Replies: 0
    Last Post: 12-27-2012, 07:39 PM
  3. Replies: 2
    Last Post: 12-26-2012, 08:31 AM
  4. VBA Show Message On Sheet Activate
    By Howardc in forum Excel Help
    Replies: 2
    Last Post: 10-29-2012, 08:17 PM
  5. Chart Summary help
    By sanjeevi888 in forum Excel Help
    Replies: 1
    Last Post: 07-08-2012, 06:06 PM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •