Hi!
I know there are a ton of forums about this, but I've not found anything that works for me, so I'm hoping there is something I'm missing.
I have a macro that works in three steps:
1. Gathers reports and pulls them into their own sheets (it's 11 reports with a total of about million rows). Each report has about 225 columns, so the macro also deletes the ones that are not needed
2. Combines those sheets into one
3. Pivots that data
The first two steps run with no issue. When I go to run the macro to pivot, I always get the "out of memory" error. If I save the workbook to my desktop after step two and reopen, I can run the macro to pivot with no issue.
I've tried deleting the individual sheets with the reports knowing there is a ton of data there, but that still doesn't work. Since I can save the workbook after step two, and then I can reopen and run step 3, I'm wondering if there's a way to not use as much memory so I can do it all in one go? Or is there something I could add that would work like closing and reopening? Just curious if anyone has any more insight or tricks on this that I may have missed while I was looking into it.
As always, appreciate any insight you may have
I know there are a ton of forums about this, but I've not found anything that works for me, so I'm hoping there is something I'm missing.
I have a macro that works in three steps:
1. Gathers reports and pulls them into their own sheets (it's 11 reports with a total of about million rows). Each report has about 225 columns, so the macro also deletes the ones that are not needed
Code:
Sub eGather_1537()
'''Gathers 1537s'''
Dim sWb As Workbook
Dim WS As Worksheet
Dim FolderName As String
Dim FFolder As Object, FFile As Object
Dim last_Col As Long, last_Row As Long
With CreateObject("Scripting.FileSystemObject")
FolderName = Trim(ActiveSheet.Range("B3").Value)
'Test folder validity
If Not .FolderExists(FolderName) Then
MsgBox "The folder path in Cell B3 is invalid." & vbCr & vbCr & "'" & FolderName & "'", vbOKOnly Or vbExclamation, "Folder Path Error"
Exit Sub
End If
Set FFolder = .GetFolder(FolderName)
'Process excel files in that folder
Application.EnableEvents = False
Application.ScreenUpdating = False
For Each FFile In FFolder.Files
'declare the file type of the worksheets to gather
If InStr(1, FFile.Name, ".csv", vbTextCompare) > 0 Then
If ThisWorkbook.Name <> FFile.Name Then
On Error Resume Next
Set sWb = Nothing
Set sWb = Workbooks.Open(FFile.Path)
On Error GoTo 0
If Not sWb Is Nothing Then
For Each WS In sWb.Worksheets
'declare sheet name
If WS.Name Like "max1537*" Then
WS.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
End If
'Delete unneeded Columns
Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A2").FormulaR1C1 = "=HLOOKUP(R[-1]C,Headers!R[13],1,0)"
Range("A2").Copy
Range("A1").End(xlToRight).Offset(1, 0).Select
Range(Selection, Selection.End(xlToLeft)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Rows("2:2").SpecialCells(xlCellTypeFormulas, 16).EntireColumn.Delete
Rows("2:2").Delete
'Add JobID
last_Col = Cells(1, Columns.Count).End(xlToLeft).Column
last_Row = Cells(Rows.Count, last_Col).End(xlUp).Row
Range("A1").End(xlToRight).Offset(0, 1).Formula = "File Name"
Range(Cells(2, last_Col + 1), Cells(last_Row, last_Col + 1)) = ActiveSheet.Name
Columns.AutoFit
Application.Goto Range("A1"), True
Next WS
sWb.Close False
End If
End If
End If
Next FFile
End With
Sheets("DASHBOARD").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub2. Combines those sheets into one
Code:
Sub bCombine1537()
Application.ScreenUpdating = False
Dim WS As Worksheet
Dim wsAll As Worksheet
Dim rngSrc As Range
Dim rngDest As Range
Dim lr As Long
Dim lc As Long
Set wsAll = ThisWorkbook.Worksheets("ALL")
If MsgBox("Combine 1537s?", vbYesNo) = vbNo Then Exit Sub
For Each WS In Worksheets
Select Case WS.Name
Case "DASHBOARD", "ALL", "1537", "Headers"
Case Else
With WS
Set rngSrc = .Range("A2:N" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
rngSrc.Copy
With wsAll
lr = Sheets("ALL").Cells(Rows.Count, "A").End(xlUp).Row
Set rngDest = .Cells(lr + 1, 1)
rngSrc.Copy
rngDest.PasteSpecial xlPasteValues
End With
End Select
Next WS
Application.ScreenUpdating = True
Sheets("ALL").Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets("Headers").Rows("15:15").Copy Destination:=Worksheets("ALL").Range("A1")
Sheets("ALL").Rows("2:2").Delete Shift:=xlUp
Sheets("ALL").Range("A1").End(xlToRight).Offset(0, 1).Formula = "File Name"
'Find last row in column A with data
'lr = Sheets("ALL").Cells(Rows.Count, "A").End(xlUp).Row
'Find last column in row 1 with data
lc = Sheets("ALL").Cells(1, Columns.Count).End(xlToLeft).Column
Sheets("ALL").Cells(1, lc + 1) = "Run ID"
Sheets("ALL").Range(Sheets("ALL").Cells(2, lc + 1), Sheets("ALL").Cells(lr, lc + 1)).FormulaR1C1 = "=CHOOSECOLS(TEXTSPLIT(RC[-1],""_""),2)"
Sheets("ALL").Range(Sheets("ALL").Cells(2, lc + 1), Sheets("ALL").Cells(lr, lc + 1)).Copy
Sheets("ALL").Range(Sheets("ALL").Cells(2, lc + 1), Sheets("ALL").Cells(lr, lc + 1)).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Sheets("ALL").Range(Sheets("ALL").Cells(1, lc), Sheets("ALL").Cells(lr, lc)).EntireColumn.Delete
Sheets("ALL").Cells.EntireColumn.AutoFit
Sheets("ALL").Columns("B:B").NumberFormat = "m/d/yyyy"
Sheets("DASHBOARD").Select
End Sub3. Pivots that data
The first two steps run with no issue. When I go to run the macro to pivot, I always get the "out of memory" error. If I save the workbook to my desktop after step two and reopen, I can run the macro to pivot with no issue.
Code:
Sub cPivot1537()
Dim PTable As PivotTable
Dim PCache As PivotCache
Dim PRange As Range
Dim PSheet As Worksheet
Dim DSheet As Worksheet
Dim lr As Long
Dim lc As Long
Dim pField As PivotField
Dim WS As Worksheet
Dim FPath As String
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.CutCopyMode = False
Set WS = Worksheets("ALL")
WS.Copy
Worksheets.Add After:=ActiveSheet ' This will add new worksheet
ActiveSheet.Name = "Pivot" ' This will rename the worksheet as "Pivot Sheet"
On Error GoTo 0
Set PSheet = Worksheets("Pivot")
Set DSheet = Worksheets("ALL")
'Find Last used row and column in data sheet
lr = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
lc = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
'Set the pivot table data range
Set PRange = DSheet.Cells(1, 1).Resize(lr, lc)
'Set pivot cahe
Set PCache = ActiveWorkbook.PivotCaches.Create(xlDatabase, SourceData:=PRange)
'Create blank pivot table
Set PTable = PCache.CreatePivotTable(TableDestination:=PSheet.Cells(1, 1), TableName:="Pivot")
'Insert Row Fields
With PSheet.PivotTables("Pivot").PivotFields("Disbursement Job ID")
.Orientation = xlRowField
.Position = 1
End With
With PSheet.PivotTables("Pivot").PivotFields("Payee ID")
.Orientation = xlRowField
.Position = 2
End With
With PSheet.PivotTables("Pivot").PivotFields("Carrier ID")
.Orientation = xlRowField
.Position = 3
End With
With PSheet.PivotTables("Pivot").PivotFields("Rebate Qtr End Date")
.Orientation = xlRowField
.Position = 4
End With
'Insert Column Fields (SAMPLE)
'With PSheet.PivotTables("Pivot").PivotFields("Column")
'.Orientation = xlColumnField
'.Position = 1
'End With
'Insert Value Fields
With PSheet.PivotTables("Pivot").PivotFields("Net Guarantee Amount")
.Orientation = xlDataField
.NumberFormat = "#,##0"
.Position = 1
End With
With PSheet.PivotTables("Pivot").PivotFields("Total Client Projected Billing Share")
.Orientation = xlDataField
.NumberFormat = "#,##0"
.Position = 2
End With
With PSheet.PivotTables("Pivot").PivotFields("Total Client Projected Factored Billing Share")
.Orientation = xlDataField
.NumberFormat = "#,##0"
.Position = 3
End With
With PSheet.PivotTables("Pivot").PivotFields("Total Rebate Payment Collected")
.Orientation = xlDataField
.NumberFormat = "#,##0"
.Position = 4
End With
With PSheet.PivotTables("Pivot").PivotFields("Client Total Amt Due")
.Orientation = xlDataField
.NumberFormat = "#,##0"
.Position = 5
End With
With PSheet.PivotTables("Pivot").PivotFields("Client Previous Total Disb Amt Paid")
.Orientation = xlDataField
.NumberFormat = "#,##0"
.Position = 6
End With
With PSheet.PivotTables("Pivot").PivotFields("Client Current Total Disb Amt Paid")
.Orientation = xlDataField
.NumberFormat = "#,##0"
.Position = 7
End With
'Add Run ID to Filter
With PSheet.PivotTables("Pivot").PivotFields("Run ID")
.Orientation = xlPageField
.Position = 1
End With
'Show in Tabular form
PSheet.PivotTables("Pivot").RowAxisLayout xlTabularRow
PSheet.PivotTables("Pivot").RepeatAllLabels xlRepeatLabels
'Freeze Panes
With ActiveWindow
If .FreezePanes Then .FreezePanes = False
.SplitColumn = 4
.SplitRow = 0
.FreezePanes = True
End With
'Remove Subtotals
With ActiveSheet.PivotTables("Pivot")
.ColumnGrand = False
.ShowValuesRow = False
End With
ActiveSheet.PivotTables("Pivot").PivotFields("Rebate Qtr End Date").Subtotals _
= Array(False, False, False, False, False, False, False, False, False, False, False, False _
)
ActiveSheet.PivotTables("Pivot").PivotFields("Payee ID").Subtotals = Array( _
False, False, False, False, False, False, False, False, False, False, False, False)
ActiveSheet.PivotTables("Pivot").PivotFields("Carrier ID").Subtotals = Array( _
False, False, False, False, False, False, False, False, False, False, False, False)
ActiveSheet.PivotTables("Pivot").PivotFields("Net Guarantee Amount").Subtotals _
= Array(False, False, False, False, False, False, False, False, False, False, False, False _
)
ActiveSheet.PivotTables("Pivot").PivotFields( _
"Total Client Projected Billing Share").Subtotals = Array(False, False, False, _
False, False, False, False, False, False, False, False, False)
ActiveSheet.PivotTables("Pivot").PivotFields( _
"Total Client Projected Factored Billing Share").Subtotals = Array(False, False, _
False, False, False, False, False, False, False, False, False, False)
ActiveSheet.PivotTables("Pivot").PivotFields("Total Rebate Payment Collected"). _
Subtotals = Array(False, False, False, False, False, False, False, False, False, False, _
False, False)
ActiveSheet.PivotTables("Pivot").PivotFields("Client Total Amt Due").Subtotals _
= Array(False, False, False, False, False, False, False, False, False, False, False, False _
)
ActiveSheet.PivotTables("Pivot").PivotFields( _
"Client Previous Total Disb Amt Paid").Subtotals = Array(False, False, False, _
False, False, False, False, False, False, False, False, False)
ActiveSheet.PivotTables("Pivot").PivotFields( _
"Client Current Total Disb Amt Paid").Subtotals = Array(False, False, False, False _
, False, False, False, False, False, False, False, False)
ActiveWorkbook.ShowPivotTableFieldList = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End SubI've tried deleting the individual sheets with the reports knowing there is a ton of data there, but that still doesn't work. Since I can save the workbook after step two, and then I can reopen and run step 3, I'm wondering if there's a way to not use as much memory so I can do it all in one go? Or is there something I could add that would work like closing and reopening? Just curious if anyone has any more insight or tricks on this that I may have missed while I was looking into it.
As always, appreciate any insight you may have
