Excel Macro: Create pivot table for all spreadsheets in a directory

Hello,
I have a directory of excel workbooks. Each has only one worksheet with data in it.  They will have the same layout as the attached workbook.  

I would like a macro to create a pivot table for each. With the row columns = GRIDCODE and the columns to be the sum of Area and SArea.  

The attached workbook has an example of the desired output from the pivot table.  The code below is from me recording a macro to make the pivot table and then save-as the file with 'pt' added to the filename.  

How can I get the macro below, or something like it to create this pivot table (in a new sheet) for every workbook in a directory and save-as the result to the same directory?  I have very limited macro creating skills, hence my use of the 'record a macro'.

Thank you kindly,
JE
Sub Create_pivot_table()
'
' Create_pivot_table Macro
'

'
    Sheets.Add
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "poly3d_001!R1C1:R1894C4", Version:=xlPivotTableVersion10).CreatePivotTable _
        TableDestination:="Sheet1!R3C1", TableName:="PivotTable1", DefaultVersion _
        :=xlPivotTableVersion10
    Sheets("Sheet1").Select
    Cells(3, 1).Select
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("GRIDCODE")
        .Orientation = xlRowField
        .Position = 1
    End With
    ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
        "PivotTable1").PivotFields("Area"), "Sum of Area", xlSum
    ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
        "PivotTable1").PivotFields("SArea"), "Sum of SArea", xlSum
    With ActiveSheet.PivotTables("PivotTable1").DataPivotField
        .Orientation = xlColumnField
        .Position = 1
    End With
    ActiveWindow.SmallScroll Down:=-3
    ActiveWorkbook.ShowPivotTableFieldList = False
    ChDir "C:\Users\JE\Desktop"
    ActiveWorkbook.SaveAs Filename:="C:\Users\JE\Desktop\EE-poly3d-001-pt.xls", _
        FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
End Sub

Open in new window

EE-poly3d-001.xls
justearthAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

bromy2004Commented:
Sub test()
Dim fso as new filesystemobject
Dim fsoFolder as folder
Dim fsoFile as file
Dim wb as workbook

Set Fsofolder=fso.getfolder(FolderName)
For each fsofile in fsofolder.files
Set wb=workbooks.open(fsofile.path)
OtherMacro(wb.sheets(1)
Set wb=nothing
Next fsofile

End sub

Add a reference to Microsoft scripting runtime

Change the macro to accept a sheet as a command
Sub MyMacro(Mysheet as worksheet)
End sub

And change all references to ActiveSheet to MySheet

I'll put together a sample in an hour or two (public transport)
0
kittenwhiskyCommented:
took my a long while but here's two macros:

1) openAllFilesInLocation
you specify folder containing your excel files, and macro will open each file
2) CreatePivotTable
looks at first sheet, takes table starting in range "A1", and creates a PivotTable into new sheet PivotTable.
it will save that version as workbook-pt.xls, and put it in a subfolder called pt

if you run the macro twice on the same folder, it will not display a warning sign asking you if you'd like to overwrite the existing workbook-pt.xls file. If you want these warnings, delete the appropriate lines at the end of the code.

customize as appropriate.

note: don't put the file containing the macro into the same folder as the other files.
Sub openAllfilesInALocation()
'Opens every xl file in folder and runs CreatePivotTable for each file
Dim FolderPath As String, i As Integer, wb As Workbook

Application.ScreenUpdating = False
'folder containing files
''change as appropriate
FolderPath = "C:\Desktop\FolderToSearch"

With Application.FileSearch
    'Search parameters
    .NewSearch
    .LookIn = FolderPath
    .SearchSubFolders = False
    .Filename = "*.xls"
    .Execute

    'look through each file
    For i = 1 To .FoundFiles.Count
        'Open each workbook
        Set wb = Workbooks.Open(Filename:=.FoundFiles(i))
        'create pivot table for opened workbook
            CreatePivotTable (wb.Name)
    Next i

End With
Application.ScreenUpdating = True
End Sub

Sub CreatePivotTable(Optional wbName As String)

'creates pivot table
Dim wb As Workbook
Dim PivotSht As Worksheet, DataRng As Range
Dim strSaveName As String

'define workbook, defaults to activeworkbook
If wbName = "" Then
    Set wb = ActiveWorkbook
Else
    Set wb = Workbooks(wbName)
End If

'get data range
''assumes table always starts in cell "A1" on first sheet in workbook
''change as appropriate
Set DataRng = Sheets(1).Range("A1").CurrentRegion

'create & name sheet "PivotTable"
Set PivotSht = wb.Sheets.Add
PivotSht.Name = "PivotTable"

'insert pivot table into Pivot Sheet, name it PivotTable1
wb.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=DataRng).CreatePivotTable _
    TableDestination:=PivotSht.Cells(3, 1), TableName:="PivotTable1"
    
'set up fields in PivotTable
With PivotSht.PivotTables("PivotTable1")
    'GridCode in rows
    .PivotFields("GRIDCODE").Orientation = xlRowField
    'Sum of Area & SArea in Columns
    .AddDataField .PivotFields("Area"), "Sum of Area", xlSum
    .AddDataField .PivotFields("SArea"), "Sum of SArea", xlSum
    .DataPivotField.Orientation = xlColumnField
End With
wb.ShowPivotTableFieldList = False

'save & close workbook
strSaveName = wb.Path & "\pt\"  'folder\pt
strSaveName = strSaveName & Left(wb.Name, Len(wb.Name) - 4) & "-pt.xls" 'name-pt.xls
'do not display warning if overwrite existing file
Application.DisplayAlerts = False
'save workbook
wb.SaveAs strSaveName
'reenable alerts & warnings
Application.DisplayAlerts = True
ActiveWorkbook.Close

End Sub

Open in new window

0
bromy2004Commented:
kittenwhisky,

you'll find compatibility issues if you user Application.FileSearch
It's not included in 2007 or 2010

I've made the attached code compatible and a bit more streamlined.
Again you would need to add a reference to "Microsoft Scripting RunTime"

I've attached the demo Workbook.

Option Explicit

Sub PivotAllWorkbooks()
'Opens every xl file in folder and runs CreatePivotTable for each file
Const FolderPath  As String = "C:\Desktop\FolderToSearch"
Dim Loop1         As Long
Dim wb            As Workbook

Dim fso           As New FileSystemObject
Dim fsoFolder     As Folder
Dim fsoFile       As File

Dim wb            As Workbook
Dim calc          As Integer
Dim strSaveName   As String


calc = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'folder containing files
'change as appropriate

Set fsoFolder = fso.GetFolder(FolderPath)

For Each fsoFile In fsoFolder.Files
  Set wb = Workbooks.Open(fsoFile.Path)
    CreatePivotTable (wb)
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Saving Location
    'OriginalFolder\pt\OriginalName-pt.xls
    strSaveName = wb.Path & "\pt\" & Left(wb.Name, Len(wb.Name) - 4) & "-pt.xls"
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    wb.SaveAs strSaveName
    wb.Close
  Set wb = Nothing
Next fsoFile

Application.Calculation = calc
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Sub CreatePivotTable(Optional wBook As Workbook)

'creates pivot table
Dim PivotSht    As Worksheet
Dim DataRng     As Range

'define workbook, defaults to activeworkbook
If wBook Is Nothing Then
  Set wBook = ActiveWorkbook
End If

'get data range
Set DataRng = Sheets(1).Range("A1").CurrentRegion

'create & name sheet "PivotTable"
Set PivotSht = wBook.Sheets.Add
PivotSht.Name = "PivotTable"

'insert pivot table into Pivot Sheet, name it PivotTable1
wBook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=DataRng).CreatePivotTable _
                                          TableDestination:=PivotSht.Cells(3, 1), _
                                          TableName:="PivotTable1"
                                          
'set up fields in PivotTable
With PivotSht.PivotTables("PivotTable1")

  'GridCode in rows
  .PivotFields("GRIDCODE").Orientation = xlRowField
  
  'Sum of Area & SArea in Columns
  .AddDataField .PivotFields("Area"), "Sum of Area", xlSum
  .AddDataField .PivotFields("SArea"), "Sum of SArea", xlSum
  .DataPivotField.Orientation = xlColumnField
End With

wBook.ShowPivotTableFieldList = False

End Sub

Open in new window

PivotAllWorkbooks.xls
0
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

kittenwhiskyCommented:
bromy,

Thanks for your comments. Good point regarding compatibility issue, and good coding putting th save & close commands into the openfiles macro (I wrongly assumed that changing the wb's name via the SaveAs method would create issues for the wb.Close method, which made me opt for opt for more convoluted coding)

Noticed some small errors when running your code:

1) Line 13 duplicates the declaration in line 7.

2) The call CreatePivotTable (wb) using wb as workbook argument:
For some reason, VBAbreaks on this. Same issue occurred in my original coding, I found that passing the argument as a string (ie wb.name) resolves the problem.

3) An error occurs if \pt subfolder doesn't already exist: actually this got lost somewhere in the copying & pasting in my own comment, here is the snippet:

'create "OriginalFolder\pt" subfolder, if it does not exist
On Error Resume Next
    MkDir FolderPath & "\pt"
On Error GoTo 0

Below reworked version including amendments.


Sub PivotAllWorkbooks()
'Opens every xl file in folder and runs CreatePivotTable for each file
Const FolderPath  As String = "C:\Desktop\FolderToSearch"
Dim Loop1         As Long
Dim wb            As Workbook

Dim fso           As New FileSystemObject
Dim fsoFolder     As Folder
Dim fsoFile       As File

Dim calc          As Integer
Dim strSaveName   As String


calc = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'create OriginalFolder\pt subfolder if it doesn't exist
On Error Resume Next
    MkDir FolderPath & "\pt"
On Error GoTo 0

Set fsoFolder = fso.GetFolder(FolderPath)

For Each fsoFile In fsoFolder.Files
  Set wb = Workbooks.Open(fsoFile.Path)
    CreatePivotTable (wb.Name)
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Saving Location
    'OriginalFolder\pt\OriginalName-pt.xls
    strSaveName = wb.Path & "\pt\" & Left(wb.Name, Len(wb.Name) - 4) & "-pt.xls"
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    wb.SaveAs strSaveName
    wb.Close
  Set wb = Nothing
Next fsoFile

Application.Calculation = calc
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Sub CreatePivotTable(Optional wName As String)
'creates pivot table

Dim wBook       As Workbook
Dim PivotSht    As Worksheet
Dim DataRng     As Range

'define workbook, defaults to activeworkbook
If wName = "" Then
  Set wBook = ActiveWorkbook
Else
  Set wBook = Workbooks(wName)
End If

'get data range
Set DataRng = Sheets(1).Range("A1").CurrentRegion

'create & name sheet "PivotTable"
Set PivotSht = wBook.Sheets.Add
PivotSht.Name = "PivotTable"

'insert pivot table into Pivot Sheet, name it PivotTable1
wBook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=DataRng).CreatePivotTable _
                                          TableDestination:=PivotSht.Cells(3, 1), _
                                          TableName:="PivotTable1"
                                          
'set up fields in PivotTable
With PivotSht.PivotTables("PivotTable1")

  'GridCode in rows
  .PivotFields("GRIDCODE").Orientation = xlRowField
  
  'Sum of Area & SArea in Columns
  .AddDataField .PivotFields("Area"), "Sum of Area", xlSum
  .AddDataField .PivotFields("SArea"), "Sum of SArea", xlSum
  .DataPivotField.Orientation = xlColumnField
End With

wBook.ShowPivotTableFieldList = False

End Sub

Open in new window

0
Rory ArchibaldCommented:
I haven't looked at the code but when passing arguments to a sub, if you do not use the Call statement, you should NOT enclose the arguments in parentheses. So, for example:
Call OtherSub(wb)
or
OtherSub wb

are OK, but:
OtherSub(wb)

is not. You will usually get away with it if you are not passing an object but you should avoid it as it is incorrect.
HTH,
Rory

PS With functions, you only use parentheses if you are storing the return value or using Call.
0
kittenwhiskyCommented:
thanks for your comment rorya, that was the issue in this case,

below the hopefully final version of the code
Option Explicit

Sub PivotAllWorkbooks()
'Opens every xl file in folder and runs CreatePivotTable for each file
Const FolderPath  As String = "C:\Desktop\FolderToSearch"
Dim Loop1         As Long
Dim wb            As Workbook

Dim fso           As New FileSystemObject
Dim fsoFolder     As Folder
Dim fsoFile       As File

Dim calc          As Integer
Dim strSaveName   As String


calc = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'create OriginalFolder\pt subfolder if it doesn't exist
On Error Resume Next
    MkDir FolderPath & "\pt"
On Error GoTo 0

Set fsoFolder = fso.GetFolder(FolderPath)

For Each fsoFile In fsoFolder.Files
  Set wb = Workbooks.Open(fsoFile.Path)
    CreatePivotTable wb
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Saving Location
    'OriginalFolder\pt\OriginalName-pt.xls
    strSaveName = wb.Path & "\pt\" & Left(wb.Name, Len(wb.Name) - 4) & "-pt.xls"
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    wb.SaveAs strSaveName
    wb.Close
  Set wb = Nothing
Next fsoFile

Application.Calculation = calc
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Sub CreatePivotTable(Optional wBook As Workbook)

'creates pivot table
Dim PivotSht    As Worksheet
Dim DataRng     As Range

'define workbook, defaults to activeworkbook
If wBook Is Nothing Then
  Set wBook = ActiveWorkbook
End If

'get data range
Set DataRng = Sheets(1).Range("A1").CurrentRegion

'create & name sheet "PivotTable"
Set PivotSht = wBook.Sheets.Add
PivotSht.Name = "PivotTable"

'insert pivot table into Pivot Sheet, name it PivotTable1
wBook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=DataRng).CreatePivotTable _
                                          TableDestination:=PivotSht.Cells(3, 1), _
                                          TableName:="PivotTable1"
                                          
'set up fields in PivotTable
With PivotSht.PivotTables("PivotTable1")

  'GridCode in rows
  .PivotFields("GRIDCODE").Orientation = xlRowField
  
  'Sum of Area & SArea in Columns
  .AddDataField .PivotFields("Area"), "Sum of Area", xlSum
  .AddDataField .PivotFields("SArea"), "Sum of SArea", xlSum
  .DataPivotField.Orientation = xlColumnField
End With

wBook.ShowPivotTableFieldList = False

End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
justearthAuthor Commented:
Hello,
I appreciate all the effort and experts attacking this question.  When I try to run the code I get the following error:

Compile Error: User-defined type not defined

Sub PivotAllWorkbooks() = highlighted in yellow

fso           As New FileSystemObject = highlighted in blue

Please advise,
Thanks again,
JE
0
Rory ArchibaldCommented:
You need to set a reference to the Scripting Runtime Library
0
justearthAuthor Commented:
rorya:

I am not completly familiar with this concept.  I have never had to do it for myself.

Do I just need to add:
Set fso = CreateObject("Scripting.FileSystemObject")

to the macro?

Thanks again,
Cheers,
JE
0
Rory ArchibaldCommented:
No - in the VB Editor, select Tools-References, locate the Microsoft Scripting Runtime library in the list and check it. (It may just be called the Scripting Runtime - I can't recall offhand and I'm on a Mac at the moment)
0
justearthAuthor Commented:
Thanks for all the help. This worked Nicely.

Cheers,
JE
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Visual Basic Classic

From novice to tech pro — start learning today.