VBA code to copy to new workbook and insert pivot

[newbiee]

Hi

I am new at this level of VBA can anyone help me

I have a wokbook with a sheet called "Datasheet" and I would like to split the data by the "Origin" and insert a Pivot Table from the Datasheet.


1 Sorts the column D4 (Field: Origin) from Datasheet
2 Filter "USA" from column D4 and copy into new workbooks
3 rename the worksheet as "USA"
4 Insert a Pivot table from "USA" worksheet
5 Add "Origin","Type", "Make" & "Engine Size" into row field and add "MSRP" into sum field
6 Save as the workbook as "USA Car Sales as at September 2019"
7 repeat step 2 to step 6 for "ASIA" & "EUROPE"


I have shown an sample for a "USA" sheet and a pivot table. How can write a VBA to automate it for my monthly report.

Thank you in advance

[mana]

Option Explicit


Sub test()
Dim tbl As Range
Dim c As Range
Dim ws As Worksheet
Dim s As String

Set tbl = Sheets("Datasheet").Range("A4").CurrentRegion
Set c = tbl(1).Offset(, tbl.Columns.Count + 2)
tbl.Columns(4).AdvancedFilter xlFilterCopy, , c, True

Do While c(2).Value <> ""
Set ws = Workbooks.Add(xlWBATWorksheet).Sheets(1)
s = c(2).Value
ws.Name = s
tbl.AdvancedFilter xlFilterCopy, c.Resize(2), ws.Range("A4")
ws.Range("A1").Value = s & " " & tbl.Parent.Range("A1").Value

With ws.Parent.PivotCaches.Create(xlDatabase, ws.Range("A4").CurrentRegion).CreatePivotTable("")
.Parent.Name = "Summary"
.RowAxisLayout xlTabularRow
.AddFields RowFields:=Array("Origin", "Type", "Make", "EngineSize")
.AddDataField .PivotFields("MSRP"), , xlSum
End With

Application.DisplayAlerts = False
ws.Parent.SaveAs ThisWorkbook.Path & "\" & ws.Range("A1").Value, xlOpenXMLWorkbook
Application.DisplayAlerts = True
ws.Parent.Close False
c(2).Delete xlShiftUp
Loop
c.ClearContents

End Sub




マナ

[newbiee]

Option Explicit


Sub test()
Dim tbl As Range
Dim c As Range
Dim ws As Worksheet
Dim s As String

Set tbl = Sheets("Datasheet").Range("A4").CurrentRegion
Set c = tbl(1).Offset(, tbl.Columns.Count + 2)
tbl.Columns(4).AdvancedFilter xlFilterCopy, , c, True

Do While c(2).Value <> ""
Set ws = Workbooks.Add(xlWBATWorksheet).Sheets(1)
s = c(2).Value
ws.Name = s
tbl.AdvancedFilter xlFilterCopy, c.Resize(2), ws.Range("A4")
ws.Range("A1").Value = s & " " & tbl.Parent.Range("A1").Value

With ws.Parent.PivotCaches.Create(xlDatabase, ws.Range("A4").CurrentRegion).CreatePivotTable("")
.Parent.Name = "Summary"
.RowAxisLayout xlTabularRow
.AddFields RowFields:=Array("Origin", "Type", "Make", "EngineSize")
.AddDataField .PivotFields("MSRP"), , xlSum
End With

Application.DisplayAlerts = False
ws.Parent.SaveAs ThisWorkbook.Path & "\" & ws.Range("A1").Value, xlOpenXMLWorkbook
Application.DisplayAlerts = True
ws.Parent.Close False
c(2).Delete xlShiftUp
Loop
c.ClearContents

End Sub




マナ

Thanks Mana

i try to change the path name to
ws.Parent.SaveAs D:\Users\409000\Desktop.Path & "" & ws.Range("A1").Value, xlOpenXMLWorkbook
but it doesn't works. Am I missing somethings? Appreciate your advice

[mana]

ws.Parent.SaveAs CreateObject("wscript.shell").specialfolders("desktop") & "\" & ws.Range("A1").Value, xlOpenXMLWorkbook

[Paul_Hossler]

Thanks Mana

i try to change the path name to
ws.Parent.SaveAs D:\Users\409000\Desktop.Path & "" & ws.Range("A1").Value, xlOpenXMLWorkbook


but it doesn't works. Am I missing somethings? Appreciate your advice


mana's works (and is better), but for future reference, that's not really a 'Path'

You wanted a string for the path, something like this



ws.Parent.SaveAs "D:\Users\409000\Desktop\" & ws.Range("A1").Value, xlOpenXMLWorkbook