ParaGlow
asked on
Macro erroring out
The attached file has 5 macros.
If the number of rows in tab “MSP_CM_Dump” is under 65,000 rows I am able to run all 5 macros.
If the number of rows in tab “MSP_CM_Dump” is over 70,000 rows I am able to run Macro 1, 2, and 3. But I get a type mismatch error when I run Macro 4.
Any help to fix this will be highly appreciated.
Test-file123.xlsm
If the number of rows in tab “MSP_CM_Dump” is under 65,000 rows I am able to run all 5 macros.
If the number of rows in tab “MSP_CM_Dump” is over 70,000 rows I am able to run Macro 1, 2, and 3. But I get a type mismatch error when I run Macro 4.
Any help to fix this will be highly appreciated.
Test-file123.xlsm
I copied all existing rows in "MS_CM_Dump" and pasted it below the existing rows yielding about 140K rows. Macro 4 still ran without errors. Can you hit debug on your error message and post the screenshot the erroneous line of code?
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Yes all the macros run now. Thank you, sir.
Apologies there is a logic error in there - please use this code instead:
Option Explicit
Sub ProcessRollFwd(sFile As String)
Dim wsRollFwd As Excel.Worksheet
Dim wsPrevMonth As Excel.Worksheet
Dim wsCurrMonth As Excel.Worksheet
Dim rgPrevious As Excel.Range
Dim rgCurrent As Excel.Range
Dim rgAddTotals As Excel.Range
Dim rgSubtractTotals As Excel.Range
Dim dNewClients As Object
Dim dOldClients As Object
Dim vData
Dim vOut
Dim lCount As Long
Dim lSubtractRow As Long
Dim sMonthName As String
Set wsRollFwd = ThisWorkbook.Worksheets(sFile & "_ROLL_FWD")
Set wsPrevMonth = ThisWorkbook.Worksheets(sFile & "_PrevMonth")
Set wsCurrMonth = ThisWorkbook.Worksheets(sFile & "_CurrMonth")
sMonthName = Format$(ThisWorkbook.Worksheets(sFile & "_CM_Dump").Range("A2").Value, "mmmm")
Application.ScreenUpdating = False
With wsRollFwd
' get PrevMonth totals
.Range("L6").Value2 = Application.WorksheetFunction.Count(wsPrevMonth.Range("A:A"))
.Range("M6").Value2 = Application.WorksheetFunction.Sum(wsPrevMonth.Range("K:K"))
' clear existing data for new input
.Range("A9", .Cells(.Rows.Count, "M")).Clear
.Range("A:A").Font.Bold = True
Set rgCurrent = SortSheetByClient(wsCurrMonth)
Set rgPrevious = SortSheetByClient(wsPrevMonth)
Set dOldClients = CreateObject("Scripting.Dictionary")
Set dNewClients = CreateObject("Scripting.Dictionary")
GetNewAndMissingClients rgPrevious, rgCurrent, dOldClients, dNewClients
lCount = dNewClients.Count
If lCount > 0 Then
vData = dNewClients.items
.Range("C9").Resize(lCount, 11).Value2 = FlattenArray(vData)
With .Range("L9").Resize(lCount, 1)
.Value2 = 1
Set rgAddTotals = .Offset(lCount).Resize(1, 2)
End With
Else
Set rgAddTotals = .Range("L10:M10")
End If
With .Cells(rgAddTotals.Row, "A")
.Value = "TOTAL ADDITIONS"
.Offset(2).Value = "SUBTRACTIONS"
End With
With rgAddTotals
.FormulaR1C1 = "=SUM(R9C:R[-1]C)"
.Borders(xlEdgeTop).LineStyle = 1
.Borders(xlEdgeBottom).LineStyle = -4119
lSubtractRow = .Row + 3
End With
lCount = dOldClients.Count
If lCount > 0 Then
vData = dOldClients.items
.Cells(lSubtractRow, "C").Resize(lCount, 11).Value2 = FlattenArray(vData)
With .Cells(lSubtractRow, "L").Resize(lCount, 1)
.Value2 = -1
Set rgSubtractTotals = .Offset(lCount).Resize(1, 2)
End With
Else
Set rgSubtractTotals = .Cells(lSubtractRow, "L").Resize(1, 2)
End If
With .Cells(rgSubtractTotals.Row, "A")
.Value = "TOTAL SUBTRACTIONS"
.Offset(2).Value = "CHANGE IN UPB FOR MONTH"
.Offset(4).Value = "Ending balance " & sMonthName & " File"
.Offset(6).Value = "ATLAS OMSR: " & sMonthName & " File"
.Offset(7).Value = "check (s/b zero)"
End With
With rgSubtractTotals
.FormulaR1C1 = "=SUM(R" & lSubtractRow - 1 & "C:R[-1]C)"
.Borders(xlEdgeTop).LineStyle = 1
.Borders(xlEdgeBottom).LineStyle = -4119
.Offset(2, 1).Resize(1, 1).FormulaR1C1 = "=R" & rgAddTotals.Row & "C+R" & rgSubtractTotals.Row & "C"
.Offset(4).FormulaR1C1 = "=R6C+R" & rgAddTotals.Row & "C+R" & rgSubtractTotals.Row & "C"
.Offset(6).Cells(1).FormulaR1C1 = "=COUNT('" & sFile & "_CurrMonth'!C1)"
.Offset(6).Cells(1, 2).FormulaR1C1 = "=SUM('" & sFile & "_CurrMonth'!C[-2])"
.Offset(7).FormulaR1C1 = "=R[-3]C-R[-1]C"
End With
With .Cells.Font
.Name = "Consolas"
.Size = 8
End With
.Range("A:L").NumberFormat = "General"
.Range("E:E").NumberFormat = "mm/dd/yyyy"
.Range("M:M").NumberFormat = "#,##0.00_);[Red](#,##0.00);""-""_)"
.Range("A:M").EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
End Sub
Function SortSheetByClient(ws As Excel.Worksheet) As Excel.Range
Dim vRow As Variant
Dim lLastRow As Long
Dim lLastCol As Long
Const csHEADER As String = "CLIENT_ID"
With ws
vRow = Application.Match(csHEADER, .Range("A:A"), 0)
If IsError(vRow) Then
MsgBox "Can't find " & csHEADER & " header - aborting."
' note this is intentional!
End
End If
lLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
lLastCol = .Cells(vRow, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(vRow, "A"), .Cells(lLastRow, lLastCol)).Sort key1:=.Cells(vRow, "A"), Header:=xlYes
' don't want header row for later processing
Set SortSheetByClient = .Range(.Cells(vRow + 1, "A"), .Cells(lLastRow, "K"))
End With
End Function
Sub GetNewAndMissingClients(rgPrev As Excel.Range, rgCurr As Excel.Range, dOldClients As Object, dNewClients As Object)
Dim vPrev
Dim vCurr
Dim x As Long
Dim vData
' collect existing clients
vPrev = rgPrev.Columns(1).Value2
For x = 1 To UBound(vPrev, 1)
vData = rgPrev.Rows(x).Value2
' want amounts treated as negatives later
vData(1, UBound(vData, 2)) = -vData(1, UBound(vData, 2))
dOldClients(CStr(vPrev(x, 1))) = vData
Next x
vPrev = Empty
vCurr = rgCurr.Value2
For x = 1 To UBound(vCurr, 1)
If Not dOldClients.Exists(CStr(vCurr(x, 1))) Then
dNewClients.Add CStr(vCurr(x, 1)), rgCurr.Rows(x).Value2
Else
dOldClients.Remove CStr(vCurr(x, 1))
End If
Next x
vCurr = Empty
End Sub
Function FlattenArray(v As Variant) As Variant
Dim vOut()
Dim x As Long
Dim y As Long
ReDim vOut(1 To UBound(v) + 1, LBound(v(0), 2) To UBound(v(0), 2))
For x = LBound(vOut) To UBound(vOut)
For y = LBound(vOut, 2) To UBound(vOut, 2)
vOut(x, y) = v(x - 1)(1, y)
Next y
Next x
FlattenArray = vOut
End Function