Hi Team
Kindly help
I have workbook where the info are copied from the sheets into a main master sheet and the subsequent info is shown in pivot. But when I run the macro/button I am getting this error
I saw in various posts and forums but it is not getting sorted. Please help
Macro below
'Global Variables
Dim MaxRows As Integer
Dim MaxCols As Integer
Sub MergeTabs()
'Init global variables
MaxRows = 200
MaxCols = 23
Dim mySheets() As Worksheet
Dim noCopy(4) As Worksheet
Dim copyFirst(1) As Worksheet
Dim master As Worksheet
Dim tabsheet As Worksheet
Dim destRng As Range
Dim pivot As PivotTable
'List of sheets to be copied before the main loop of this program
Set copyFirst(0) = Sheets("Header")
'List of sheets not to be copied in the main loop of this program
Set noCopy(0) = Sheets("Master")
Set noCopy(1) = Sheets("Legend")
Set noCopy(2) = Sheets("Summary")
Set noCopy(3) = Sheets("Header")
'First prepare a list of sheets to be merged
'List should exclude sheets that should not be copied
ReDim mySheets(Sheets.Count)
'set up mySheets so that the Header rows are copied
Set mySheets(0) = copyFirst(0)
'Redimension mySheets so that it contains only as many
'sheets as must be copied
offst = 0
For i = 1 To UBound(mySheets) 'LB is set to 1 as mySheets(0) = Header
If ((Sheets.Item(i).Name <> noCopy(0).Name) And _
(Sheets.Item(i).Name <> noCopy(1).Name) And _
(Sheets.Item(i).Name <> noCopy(2).Name) And _
(Sheets.Item(i).Name <> noCopy(3).Name)) _
Then
Set mySheets(i - offst) = Sheets(i)
'Debug.Print mySheets(i - offst).Name
Else
'Debug.Print "Redim to size: " & UBound(mysheets) - 1
ReDim Preserve mySheets(UBound(mySheets) - 1)
offst = offst + 1
End If
Next i
'Debug.Print "Array size: " & UBound(mySheets)
'Next, start merging sheets one by one into "Master"
Set master = Sheets("Master")
Set destRng = master.Range("A1")
Debug.Print ""
Debug.Print "Clearing contents of " & master.Name
master.Cells.Clear
'copy the tabs registered in mySheets
For i = 0 To UBound(mySheets)
Set tabsheet = mySheets(i)
Debug.Print "Copying contents of " & tabsheet.Name & " to " & master.Name
Call CopyRange(tabsheet, master, destRng)
offrow = LastRow(master)
Set destRng = master.Range("A1").Offset(offrow, 0)
Next
Application.ScreenUpdating = False
Call RefreshPivots("Summary")
Application.ScreenUpdating = True
End Sub
Sub RefreshPivots(tname As String)
Dim pt As PivotTable
Dim sheet As Worksheet
Dim master As Worksheet
Debug.Print "Refreshing pivots in " & tname & " tab"
'figure out the last row and column of Master tab
Set master = Sheets("Master")
lrow = LastRow(master)
lcol = Lastcol(master)
rng = "A1" & ":W" & lrow 'TODO: HARDCODED TO A1:Wxxx - REFACTOR THIS
Debug.Print "MASTER Last Row: " & lrow & "; Last Col: " & lcol & "; Range: " & rng
Set sheet = Worksheets(tname)
For Each pt In sheet.PivotTables
Debug.Print "Refreshing " & pt.Name
'Change the data source for each pivot
pt.ChangePivotCache ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:=master.Name & "!" & Range(rng).Address(ReferenceStyle:=xlR1C1))
pt.RefreshTable
Next pt
End Sub
Sub RefreshPivot(tname As String)
'THIS IS A DEPRECATED SUB
'RETAINED HERE AS REFERENCE OR FUTURE USE
Dim pivot As PivotTable
Set pivot = Sheets("Summary").PivotTables(tname)
pivot.RefreshTable
End Sub
Sub CopyRange(sht As Worksheet, dst As Worksheet, dstrng As Range)
Dim rng As Range
lrow = LastRow(sht)
lcol = Lastcol(sht)
Set rng = sht.Range(Cells(2, 1).Address & ":" & Cells(lrow, lcol).Address)
rng.Copy Destination:=dstrng
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
'If more than MaxRows are to be copied, then it is an error.
'Copy only MaxRows rows.
If LastRow > MaxRows And sh.Name <> "Master" Then
Debug.Print "Warning: Found " & LastRow & " rows in " & sh.Name & ". Copying only " & MaxRows & " rows."
MsgBox "Warning: Found " & LastRow & " rows in " & sh.Name & ". Copying only " & MaxRows & " rows."
LastRow = MaxRows
End If
End Function
Function Lastcol(sh As Worksheet)
On Error Resume Next
Lastcol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
'If more than MaxCols columns are to be copied, then it is an error.
'Copy only MaxCols columns
If Lastcol > MaxCols And sh.Name <> "Master" Then
Debug.Print "Warning: Found " & Lastcol & " cols in " & sh.Name & ". Copying only " & MaxCols & " cols."
MsgBox "Warning: Found " & Lastcol & " cols in " & sh.Name & ". Copying only " & MaxCols & " cols."
Lastcol = MaxCols
End If
End Function
Kindly help
I have workbook where the info are copied from the sheets into a main master sheet and the subsequent info is shown in pivot. But when I run the macro/button I am getting this error
I saw in various posts and forums but it is not getting sorted. Please help
Macro below
'Global Variables
Dim MaxRows As Integer
Dim MaxCols As Integer
Sub MergeTabs()
'Init global variables
MaxRows = 200
MaxCols = 23
Dim mySheets() As Worksheet
Dim noCopy(4) As Worksheet
Dim copyFirst(1) As Worksheet
Dim master As Worksheet
Dim tabsheet As Worksheet
Dim destRng As Range
Dim pivot As PivotTable
'List of sheets to be copied before the main loop of this program
Set copyFirst(0) = Sheets("Header")
'List of sheets not to be copied in the main loop of this program
Set noCopy(0) = Sheets("Master")
Set noCopy(1) = Sheets("Legend")
Set noCopy(2) = Sheets("Summary")
Set noCopy(3) = Sheets("Header")
'First prepare a list of sheets to be merged
'List should exclude sheets that should not be copied
ReDim mySheets(Sheets.Count)
'set up mySheets so that the Header rows are copied
Set mySheets(0) = copyFirst(0)
'Redimension mySheets so that it contains only as many
'sheets as must be copied
offst = 0
For i = 1 To UBound(mySheets) 'LB is set to 1 as mySheets(0) = Header
If ((Sheets.Item(i).Name <> noCopy(0).Name) And _
(Sheets.Item(i).Name <> noCopy(1).Name) And _
(Sheets.Item(i).Name <> noCopy(2).Name) And _
(Sheets.Item(i).Name <> noCopy(3).Name)) _
Then
Set mySheets(i - offst) = Sheets(i)
'Debug.Print mySheets(i - offst).Name
Else
'Debug.Print "Redim to size: " & UBound(mysheets) - 1
ReDim Preserve mySheets(UBound(mySheets) - 1)
offst = offst + 1
End If
Next i
'Debug.Print "Array size: " & UBound(mySheets)
'Next, start merging sheets one by one into "Master"
Set master = Sheets("Master")
Set destRng = master.Range("A1")
Debug.Print ""
Debug.Print "Clearing contents of " & master.Name
master.Cells.Clear
'copy the tabs registered in mySheets
For i = 0 To UBound(mySheets)
Set tabsheet = mySheets(i)
Debug.Print "Copying contents of " & tabsheet.Name & " to " & master.Name
Call CopyRange(tabsheet, master, destRng)
offrow = LastRow(master)
Set destRng = master.Range("A1").Offset(offrow, 0)
Next
Application.ScreenUpdating = False
Call RefreshPivots("Summary")
Application.ScreenUpdating = True
End Sub
Sub RefreshPivots(tname As String)
Dim pt As PivotTable
Dim sheet As Worksheet
Dim master As Worksheet
Debug.Print "Refreshing pivots in " & tname & " tab"
'figure out the last row and column of Master tab
Set master = Sheets("Master")
lrow = LastRow(master)
lcol = Lastcol(master)
rng = "A1" & ":W" & lrow 'TODO: HARDCODED TO A1:Wxxx - REFACTOR THIS
Debug.Print "MASTER Last Row: " & lrow & "; Last Col: " & lcol & "; Range: " & rng
Set sheet = Worksheets(tname)
For Each pt In sheet.PivotTables
Debug.Print "Refreshing " & pt.Name
'Change the data source for each pivot
pt.ChangePivotCache ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:=master.Name & "!" & Range(rng).Address(ReferenceStyle:=xlR1C1))
pt.RefreshTable
Next pt
End Sub
Sub RefreshPivot(tname As String)
'THIS IS A DEPRECATED SUB
'RETAINED HERE AS REFERENCE OR FUTURE USE
Dim pivot As PivotTable
Set pivot = Sheets("Summary").PivotTables(tname)
pivot.RefreshTable
End Sub
Sub CopyRange(sht As Worksheet, dst As Worksheet, dstrng As Range)
Dim rng As Range
lrow = LastRow(sht)
lcol = Lastcol(sht)
Set rng = sht.Range(Cells(2, 1).Address & ":" & Cells(lrow, lcol).Address)
rng.Copy Destination:=dstrng
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
'If more than MaxRows are to be copied, then it is an error.
'Copy only MaxRows rows.
If LastRow > MaxRows And sh.Name <> "Master" Then
Debug.Print "Warning: Found " & LastRow & " rows in " & sh.Name & ". Copying only " & MaxRows & " rows."
MsgBox "Warning: Found " & LastRow & " rows in " & sh.Name & ". Copying only " & MaxRows & " rows."
LastRow = MaxRows
End If
End Function
Function Lastcol(sh As Worksheet)
On Error Resume Next
Lastcol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
'If more than MaxCols columns are to be copied, then it is an error.
'Copy only MaxCols columns
If Lastcol > MaxCols And sh.Name <> "Master" Then
Debug.Print "Warning: Found " & Lastcol & " cols in " & sh.Name & ". Copying only " & MaxCols & " cols."
MsgBox "Warning: Found " & Lastcol & " cols in " & sh.Name & ". Copying only " & MaxCols & " cols."
Lastcol = MaxCols
End If
End Function
