VBA create multiple excel files

[VETROVJ]

Hi, I hope someone can help me. I'm trying to find out why the below macro doesnt work and tried to search online with no luck. My skills are clearly very basic so would appreciate if you can point me to the right direction.

I have template with 3 sheets, 2 are pivot tables and 1 is "Customer raw data". I have a column number 59 which is a unique key to a file name that has to be created and the raw data has to be copied there. I want also the two pivot table sheets to be copied but I'm not able as the highlighted line in red is giving me errors. I will after also add the refresh pivot table and to connect to the right source of data but that would be next step.

Sub CSVSpliter()
Dim wb As Workbook, c As Range
With ActiveSheet
Intersect(.Columns(59), .UsedRange).AdvancedFilter xlFilterCopy, , .Cells(Rows.Count, 2).End(xlUp)(3), True
For Each c In .Cells(Rows.Count, 2).End(xlUp).CurrentRegion.Offset(1)


If c <> "" Then
Set wb = Workbooks.Add
.UsedRange.AutoFilter 59, c.Value
.UsedRange.SpecialCells(xlCellTypeVisible).Copy
wb.Sheets(1).Range("a1").PasteSpecial xlPasteAll
wb.Sheets(1).Range("BG:BG").EntireColumn.Delete
ActiveSheet.Name = "Customer raw data"

wb.Sheets(Array("Top_Line_Reconcile", "Units_by_Month")).Copy



wb.SaveAs ThisWorkbook.Path & "\" & c.Value & ".xlsx" ', 6
.AutoFilterMode = False
wb.Close False
End If
Next
.Cells(Rows.Count, 2).End(xlUp).CurrentRegion.ClearContents
End With
End Sub

 

[Jeffrey Mahoney]

So that line in red is supposed to copy 2 sheets from the newly created workbook (Set wb = Workbooks.Add) over to a brand new workbook

Logic:
Set wb = Workbooks.Add 'Add new workbook with blank sheets (WB2)
.UsedRange.AutoFilter 59, c.Value 'Filter data on last workbook (WB1)
.UsedRange.SpecialCells(xlCellTypeVisible).Copy 'Copy data from ActiveSheet from WB1 to WB2
wb.Sheets(1).Range("a1").PasteSpecial xlPasteAll 'Paste data from ActiveSheet from WB1 to WB2
wb.Sheets(1).Range("BG:BG").EntireColumn.Delete 'Delete BG column on sheet on WB2
ActiveSheet.Name = "Customer raw data" 'Rename 1st Sheet on WB2

wb.Sheets(Array("Top_Line_Reconcile", "Units_by_Month")).Copy 'Try to copy 2 sheets from WB2 that don't exist over to a brand new workbook

 

[Jeffrey Mahoney]

What you may have wanted to do is Copy all 3 sheets from your original WB over to WB2, then start working on that and save it.

 

[VETROVJ]

wb.Sheets(Array("Top_Line_Reconcile", "Units_by_Month")).Copy ' so should i change this part only and it should work? I dont know what you mean with the second comment? thanks a lot for you answer

 

[Jeffrey Mahoney]

What's going on is that the red line is trying to copy sheets in a new workbook that don't exist. Those probably exist in the original workbook, right?

I can see that you're trying to copy filtered data from the original Raw Data based on values in column 59. That seems fine. Are you then trying to copy the sheets "Top_Line_Reconcile" and "Units_by_Month" from the original workbook?

 

[VETROVJ]

yes exactly, I just found a solution, I have "Set origWb = ThisWorkbook", which reference to the original workbook. THnak you so much!

origWb.Sheets(Array("TopLineReconcile", "UnitsbyMonth")).Copy Before:=wb.Sheets(1)


Now I will try to update the source of the pivots to this new workbook where I copy them...

 

[Jeffrey Mahoney]

There you go.

 

[VETROVJ]

Now Im trying to refresh the pivot data source to the new file name that is created with the new "range", but it keeps to be pointing to the old file that the pivot/sheets are copied from. any suggestion?

Sub Seasonaltemplatecreator()
Dim wb As Workbook, c As Range
Dim pt As PivotTable
Dim ws As Worksheet
Dim newWb As Workbook
Dim newRange As Range
Set origWb = ThisWorkbook

With ActiveSheet
    Intersect(.Columns(59), .UsedRange).AdvancedFilter xlFilterCopy, , .Cells(Rows.Count, 2).End(xlUp)(3), True
    For Each c In .Cells(Rows.Count, 2).End(xlUp).CurrentRegion.Offset(1)
    

        If c <> "" Then
            Set wb = Workbooks.Add
            .UsedRange.AutoFilter 59, c.Value
            .UsedRange.SpecialCells(xlCellTypeVisible).Copy
            wb.Sheets(1).Range("a1").PasteSpecial xlPasteAll
            wb.Sheets(1).Range("BG:BG").EntireColumn.Delete
            ActiveSheet.Name = "CustomerRawdata" 'Range("A2" & "Raw Data").Value
            
            origWb.Sheets(Array("TopLineReconcile", "UnitsByMonth")).Copy Before:=wb.Sheets(1)
            
            wb.SaveAs ThisWorkbook.Path & "\" & c.Value & ".xlsx" ', 6
            .AutoFilterMode = False
            
            
            
            Set ws = wb.Sheets("TopLineReconcile")
            Set pt = ws.PivotTables("PivotTable1")
            
            Set newRange = wb.Sheets("CustomerRawdata").Range("A1:B20")
            
            Debug.Print newRange.Parent.Name
            Debug.Print newRange.Address
            
            pt.ChangePivotCache wb.PivotCaches.Create( _
                SourceType:=1, _
                SourceData:=newRange.Address(External:=True))
            pt.RefreshTable
            
            
            
            
            
            
            wb.Close False
        End If
    Next
    .Cells(Rows.Count, 2).End(xlUp).CurrentRegion.ClearContents
End With
End Sub

 

[VETROVJ]

Solved thanks a lot for your inputs very helpful Jeffrey