VBA to Get SUMMARY of Multipple Sheet

[mag]

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]

Hi Mag,

Hope this will help you.


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]

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


Thanks

[LalitPandey87]

Find solution at below mentioned link

533

:cheers:

[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.

[Rajan_Verma]

You can use Consolidate to get it done..

Rajan.

[LalitPandey87]

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




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(varColumnHead er), UBound(varColumnHeader, 2)).Value = varColumnHeader
If LCase(varColumnHeader(1, 2)) = "values" Then
.Range(strPvtTblDesti).Resize(rngData.Resize(1).Ro ws.Count, rngData.Resize(1).Columns.Count).Offset(1).Value = rngData.Resize(1).Value
Else
.Range(strPvtTblDesti).Resize(rngData.Resize(1).Ro ws.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:

[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..

[LalitPandey87]

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




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).CurrentRegi on)
.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(varColumnHead er), UBound(varColumnHeader, 2)).Value = varColumnHeader
If LCase(varColumnHeader(1, 2)) = LCase(strPvtFirstRowVal) Then
.Range(strPvtTblDesti).Resize(rngData.Resize(1).Ro ws.Count, rngData.Resize(1).Columns.Count).Offset(1).Value = rngData.Resize(1).Value
Else
.Range(strPvtTblDesti).Resize(rngData.Resize(1).Ro ws.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:

[mag]

Thanks Lalit That Works Fine :cheerio:

[LalitPandey87]

Your welcome mag :thumbsup: :hug: