VBA code for processing data in an Excel file crashes after processing about 400-500 rows

I have coded a VBA macro to process downloaded data. The data has some junk rows that need to be deleted, but also has some rows where the data is off by a couple of columns and a couple of rows. The macro moves data to the right place and deletes unnecessary rows.

It works well for about 400-500 rows and then it crashes. The data I am trying to process is about 900-1,000 rows.

Here is an example of a few rows of the raw data:

Here is the desired output:

Here is the code:

Option Explicit

Public Function ContainsArrayValue(StringToCheck As String, ValuesToLookFor As Variant) As Boolean
    Dim i As Long
    For i = LBound(ValuesToLookFor) To UBound(ValuesToLookFor)
        If InStr(1, StringToCheck, ValuesToLookFor(i)) > 0 Then
            ContainsArrayValue = True
            Exit Function
        End If
    Next i
    ContainsArrayValue = False
End Function

Public Function IsInArray(StringToBeFound As String, ValuesToCheck As Variant) As Boolean
    Dim i As Long
    For i = LBound(ValuesToCheck) To UBound(ValuesToCheck)
        If ValuesToCheck(i) = StringToBeFound Then
            IsInArray = True
            Exit Function
        End If
    Next i
    IsInArray = False
End Function

Public Function IsDivisible(x As Integer, d As Integer) As Boolean
    IsDivisible = (x Mod d) = 0
End Function

Sub CleanUpTwoLines(ReferenceRow As Range)
    Dim i As Long
    Dim TargetRange As Range
    Dim SourceRange As Range
    Dim TargetRow1 As Range
    Dim TargetRow2 As Range

    Set TargetRange = Range(ReferenceRow.Cells(1, 5), ReferenceRow.Cells(1, 17))
    Set SourceRange = TargetRange.Offset(2, -1)
    
    For i = 1 To 13
        TargetRange.Cells(1, i).Value = SourceRange.Cells(1, i)
    Next i

    Set TargetRow1 = ReferenceRow.Offset(1, 0).EntireRow
    Set TargetRow2 = ReferenceRow.Offset(2, 0).EntireRow
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    TargetRow1.Delete
    TargetRow2.Delete
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Sub CleanUpOneLine(ReferenceRow As Range)
    Dim TargetRow1 As Range
    Set TargetRow1 = ReferenceRow.Offset(1, 0).EntireRow
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    TargetRow1.Delete
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Sub PlayerRowCleanup(PlayerRow As Range, PlayerPosValues As Variant)
    If IsInArray(PlayerRow.Cells(1, 1).Offset(2, 0).Value, PlayerPosValues) = False Then                                    'We already know the line below is not a player; if the line two rows below is also not a player...
        Call CleanUpTwoLines(PlayerRow)                                                                                                         'Then do the two-line cleanup, which involves moving stats and deleting those two rows
    Else                                                                                                                                                            'If it's in fact just one row that's not a player...
        Call CleanUpOneLine(PlayerRow)                                                                                                           'Then delete that row
    End If
    
    While IsInArray(PlayerRow.Cells(1, 1).Offset(1, 0).Value, PlayerPosValues) = False                                     'Check if there are any extra non-player rows...
        PlayerRow.Cells(1, 1).Offset(1, 0).EntireRow.Delete                                                                               'If so delete them
    Wend
End Sub

Sub CleanUpAllRosterData()
    Dim JunkRowValues() As String
    Dim PlayerPosValues() As String
    Dim a As Range, b As Range
    Dim RowsToDelete As Range
    Dim counter As Integer

    JunkRowValues = Split("Batters,Pitchers,Minors,Injured,Pos,pitchers,Schedule,Not In Lineup", ",")
    PlayerPosValues = Split("C,1B,2B,SS,3B,MI,CI,OF,U,P", ",")
    
    Set a = Range("AllTeamsData")
    a.Cells.UnMerge
    counter = 0
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    For Each b In a.Rows
        counter = counter + 1
        If IsDivisible(counter, 20) Then
            If MsgBox("Analyzing row " & b.Row & " processed " & counter & " rows. Continue?", vbYesNo) = vbNo Then
                Exit For
            End If
        End If
        
        If ContainsArrayValue(b.Cells(1, 1).Value, JunkRowValues) Then                                                        'Check whether the current row is junk
            If RowsToDelete Is Nothing Then                                                                                                  'If it is delete it
                Set RowsToDelete = b.EntireRow
            Else
                Set RowsToDelete = Union(RowsToDelete, b.EntireRow)
            End If
        ElseIf IsInArray(b.Cells(1, 1).Value, PlayerPosValues) Then                                                                 'Check whether the current row is a player row
            If Not IsInArray(b.Cells(1, 1).Offset(1, 0).Value, PlayerPosValues) Then                                         'If the next line is also a player row, then no need to do anything--go to the next row
                Call PlayerRowCleanup(b, PlayerPosValues)                                                                                'If the next line is not also a player row, then call for cleanup
            End If
        End If
    Next b
    
    If Not RowsToDelete Is Nothing Then
        RowsToDelete.Delete
    End If
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

I would greatly appreciate any thoughts on what is causing the crash after the first 400-500 rows.

I have run the code through ChatGPT and followed its suggestions. The macro still crashes.

• There is an infinite loop in PlayerRowCleanup. It leads to crash (Excel no response).

Note:

• The data of the last player (Ozzie Albies) in the source table is incomplete. So it isn't in the output.
• There are missing data in your expected output table, highlighted in green in my screenshot.

Microsoft documentation:

InStr function

Range.Resize property (Excel)

Range.AutoFit method (Excel)

Option Explicit
Sub Demo()
    Dim i As Long, j As Long
    Dim arrData, rngData As Range, sErrList As String
    Dim arrRes, iR As Long, iMode As Long
    Dim oSht As Worksheet, RowCnt As Long
     ' modify as needed, the 1st and last char should be "|"
    Const POS = "|C|1B|2B|SS|3B|MI|CI|OF|U|P|"
    Const SKIP_ROWS = 3
    Set oSht = Sheets("Data") ' modify as needed
    ' load data into an array
    arrData = oSht.UsedRange.Value
    arrRes = arrData
    RowCnt = UBound(arrData)
    iR = SKIP_ROWS
    ' loop through data
    For i = LBound(arrData) + SKIP_ROWS To RowCnt
        If Len(arrData(i, 1)) > 0 And InStr(1, POS, "|" & arrData(i, 1) & "|", vbTextCompare) > 0 Then
            ' get the row count for each player
            If RowCnt - i < 3 Then
                iMode = RowCnt - i + 1
            ElseIf InStr(1, POS, "|" & arrData(i + 3, 1) & "|", vbTextCompare) Then
                iMode = 3
            ElseIf InStr(1, POS, "|" & arrData(i + 2, 1) & "|", vbTextCompare) Then
                iMode = 2
            Else
                iMode = 0
            End If
            Select Case iMode
            Case 0 ' missing data
                sErrList = sErrList & "," & arrData(i, 1)
            Case 2 ' two rows
                iR = iR + 1
                For j = LBound(arrData, 2) To UBound(arrData, 2)
                    arrRes(iR, j) = arrData(i, j)
                Next j
                i = i + 1
            Case 3 ' three rows
                iR = iR + 1
                For j = LBound(arrData, 2) To UBound(arrData, 2)
                    If j < 3 Then
                        arrRes(iR, j) = arrData(i, j)
                    Else
                        arrRes(iR, j) = arrData(i + 2, j - 1)
                    End If
                Next j
                i = i + 2
            End Select
        End If
    Next i
    ' write output to sheet
    Sheets.Add
    Range("A2").Resize(iR, UBound(arrData, 2)).Value = arrRes
    ActiveSheet.UsedRange.EntireColumn.AutoFit
    Columns(1).ColumnWidth = 4
    If Len(sErrList) > 0 Then
        MsgBox "Missing data for:" & vbCr & Mid(sErrList, 2)
    Else
        MsgBox "Done"
    End If
End Sub

Update:

Option Explicit
Sub Demo()
    Dim i As Long, j As Long
    Dim arrData, rngData As Range, sErrList As String
    Dim arrRes, iR As Long, iMode As Long, iNext As Long
    Dim oSht As Worksheet, RowCnt As Long, bHeader As Boolean
     ' modify as needed, the 1st and last char should be "|"
    Const POS = "|C|1B|2B|SS|3B|MI|CI|OF|U|P|"
    Const SKIP_ROWS = 3
    Set oSht = Sheets("Data") ' modify as needed
    ' load data into an array
    arrData = oSht.UsedRange.Value
    arrRes = arrData
    RowCnt = UBound(arrData)
    iR = SKIP_ROWS
    ' loop through data
    For i = LBound(arrData) + SKIP_ROWS To RowCnt
        If Len(arrData(i, 1)) > 0 And InStr(1, POS, "|" & arrData(i, 1) & "|", vbTextCompare) > 0 Then
            ' locate the next player
            iMode = 0: iNext = 0: bHeader = False
            For j = i + 1 To RowCnt
                If InStr(1, POS, "|" & arrData(j, 1) & "|", vbTextCompare) Then
                    iNext = j ' start row# of next player
                    Exit For
                ElseIf UCase(Left(arrData(j, 1), 4)) = "TEAM" Then
                    bHeader = True ' extra header
                End If
            Next
            ' get the row count for each player
            If iNext > 0 Then
                iMode = iNext - i
                If bHeader Then iMode = iMode - SKIP_ROWS
            Else
                If RowCnt - i < 3 Then
                    iMode = RowCnt - i + 1
                End If
            End If
            Select Case iMode
            Case 0 ' missing data
                sErrList = sErrList & "," & arrData(i, 2)
            Case 1, 2 ' two rows
                iR = iR + 1
                For j = LBound(arrData, 2) To UBound(arrData, 2)
                    arrRes(iR, j) = arrData(i, j)
                Next j
                i = i + (iMode - 1)
            Case 3, 4 ' three rows
                iR = iR + 1
                For j = LBound(arrData, 2) To UBound(arrData, 2)
                    If j < 3 Then
                        arrRes(iR, j) = arrData(i, j)
                    Else
                        arrRes(iR, j) = arrData(i + 2, j - 1)
                    End If
                Next j
                i = i + 2
            End Select
            If bHeader Then i = i + SKIP_ROWS ' skip extra header
        End If
    Next i
    ' write output to sheet
    Sheets.Add
    Range("A2").Resize(iR, UBound(arrData, 2)).Value = arrRes
    ActiveSheet.UsedRange.EntireColumn.AutoFit
    Columns(1).ColumnWidth = 4
    If Len(sErrList) > 0 Then
        MsgBox "Missing data for:" & vbCr & Mid(sErrList, 2)
    Else
        MsgBox "Done"
    End If
End Sub