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
ParaGlowAsked:
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.

FilonowstCommented:
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?
0
ParaGlowAuthor Commented:
0
Rory ArchibaldCommented:
Please replace all the code in modCommonCode with this and let me know:

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(LBound(v) To UBound(v), LBound(v(LBound(v))) To UBound(v(LBound(v))))
    For x = LBound(vOut) To UBound(vOut)
        For y = LBound(vOut, 2) To UBound(vOut, 2)
            vOut(x, y) = v(x)(1, y)
        Next y
    Next x
    FlattenArray = vOut
End Function

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
ParaGlowAuthor Commented:
Yes all the macros run now.  Thank you, sir.
0
Rory ArchibaldCommented:
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

Open in new window

1
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
Microsoft Excel

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.