(Excel) VBA code to copy to worksheet from pivot table

[danboi10]

Hi,

First time posting on this website! Very next to vb and having spent a good few days searching the net for an answer but to no avail. I'm am hoping that someone maybe able to assist with the following query:

I have a pivot table that has two columns and 29 rows. The essential function that i'd like the VBA code to perform is to open each row to a new worksheet and the for each (29) worksheets to be copied and transferred into new workbooks (the workbooks would then be saved a name contained in the cell). I have been able to write a code that performs this function but i cannot get the code to repeat the action for each cell. The code is attached below:

Sub Macro1()
'
' Macro1 Macro
Dim Cell As Range
Dim b As Integer
Dim a As String
Dim d As String
Dim ws As Worksheet


Range("B4").Select
Selection.ShowDetail = True
ActiveSheet.Name = Range("D2").Text
Cells.Select
Selection.Copy
ActiveSheet.Name = Range("D2").Text
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Name = Range("D2").Text
Cells.Select
Cells.EntireColumn.AutoFit
ActiveWindow.Zoom = 85
Selection.RowHeight = 14.25
Cells.EntireColumn.AutoFit
Sheets("Sheet2").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Sheet3").Select
ActiveWindow.SelectedSheets.Delete
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
ActiveWorkbook.SaveAs Filename:="J:\" & Range("D2")
ActiveWorkbook.Close
End Sub


Many thanks for any help.

Dan.

[vbfbryce]

See if this gets you close:

Sub Macro1()

Dim Cell As Range
Dim b As Integer
Dim a As String
Dim d As String
Dim ws As Worksheet
Dim i As Integer    '***
Dim strName As String   '***
Dim wbNew As Workbook   '***
Dim wsNew As Worksheet  '***

For i = 2 To 3 'not exactly sure where your data is
    Range("b" & i).ShowDetail
    strName = Range("d" & i)    'save the value in D2 to name new workbook
    Range("b" & i).EntireRow.Copy
    Set wbNew = Workbooks.Add
    Set wsNew = wbNew.Sheets(1)
    wsNew.Range("a1").PasteSpecial
    'other code
    wbNew.SaveAs Filename:=strName
    wbNew.Close
    Set wbNew = Nothing
Next i

End Sub

[danboi10]

Hey vbfbryce,

Thanks for your reply unfort it didn't work and i really don't have the ability to work the coding out at this stage! But it did give me the idea to go back to basics. So i cut all the coding back and I'm just attempting to open an new work book for each cell in the pivot and work my way through the list. The following code works and opens range (B4) then returns to the pivot and opens (B5) in a new worksheet but I don't seem to be able to loop it. The coding has been done via recording of a macro.

 Range("B4:B29").Select
    Range("B4").Select
    Selection.ShowDetail = True
    Sheets("Pivot Table").Select
    Do
    Range("B5").Select
    Selection.ShowDetail = True
    Sheets("Pivot Table").Select
    Range("B6").Select
    Selection.ShowDetail = True
    Sheets("Pivot Table").Select
    DoUntillast

Again any help would be greatly appreciated.

Dan.

[vbfbryce]

Can you zip and attach your workbook?

[danboi10]

Hi,

Please accept my apologies for the delay in responding to your email. I have been on annual leave and had no access to the work files. I have slightly alter the names but the pivot table is set up as i would use it.

Many thanks for any advice.

Regards,
Dan.

[vbfbryce]

I'm having some trouble figuring out the steps you're going through. Which sheet is active when you start? Which macro do you run (I'm assuming "Macro1")?

[danboi10]

I've reattached with some amendments. The pivot table is the active sheet. Normally to open the content of the pivot you would just double click the relevant total. So Macro 1 opens B5 in a new work sheet. It should then step one line down and open b6 in a new worksheet. However i cannot make it step down/loop automatically. The only way i've worked out how to do it is by manually entering each line, which is pretty pointless!

[vbfbryce]

something like this:

    Dim i As Integer
    
    For i = 6 To 16
        Worksheets("pivot").Range("b" & i).ShowDetail = True
    Next i

[danboi10]

Hey,

That is brilliant. Thanks very much.

As i said new to this!

Dan