vba - 「メモリ不足」エラーを修正する方法

Question

私の次のコードは、ランタイム エラー 7:「メモリ不足」をポップアップ表示します。理由がわかりません。非常に長いコードではありません。エラーが発生した行を特定しました。何かご意見は？

Sub discrepancy_report()

Dim var1 As Long
Dim var2 As Long
Dim var3 As Long
Dim colrg As Range
Dim lastr As Long
Dim dr As String
Dim r As Integer
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim errbox As Integer

    r = 5
On Error GoTo DataSheetError
    Set sht1 = Sheets("DataSheet")
On Error GoTo DiscrepancySheetError
    Set sht2 = Sheets("DiscrepancyReport")
On Error GoTo 0
    sht2.Select
        Rows("9:999").Select
        Selection.Delete Shift:=xlUp
        Range("A9").Select
    sht1.Select
        lastr = ActiveSheet.Range("A1").Offset(ActiveSheet.Rows.Count - 1, 0).End(xlUp).Row
        lastr = lastr - 1

'Store Values in Array
    Dim tbl As Range
    Dim var() As Variant
    Dim c As Long, matchRow As Long
    Set tbl = Range("A3:G" & lastr)

    ReDim var(1 To tbl.Rows.Count)

        For c = 1 To tbl.Rows.Count
            var(r) = tbl(r, 1) & tbl(r, 2) & tbl(r, 3) & tbl(r, 4) & tbl(r, 5)
        Next


'Column 1: WP
        Set colrg = Range("A3:A" & lastr)
            For Each cell In colrg
                If (cell.Value) = 6.01 Or (cell.Value) = 6.03 Or (cell.Value) = 6.04 Or (cell.Value) = 6.27 Then
                Else
                    sht2.Cells(r, 1).Value = cell.Address
                    sht2.Cells(r, 2).Value = (cell.Value)
                    sht2.Cells(r, 3).Value = "Not a valid WP"
                    r = r + 1
                End If
            Next
        Set colrg = Range("B3:B" & lastr)
            For Each cell In colrg
                If (cell.Value) < 99999 And (cell.Value) > 10000 Then
                Else
                    sht2.Cells(r, 1).Value = cell.Address
                    sht2.Cells(r, 2).Value = (cell.Value)
                    sht2.Cells(r, 3).Value = "This is not a valid PCR number"
                    r = r + 1
                End If
            Next

        Set colrg = Range("C3:C" & lastr)
            For Each cell In colrg
                If (cell.Value) = "Stage 0 - Submit PCR" _
                        Or (cell.Value) = "Stage 1a - Director Approval" _
                        Or (cell.Value) = "Stage 1b - PMO Approval" _
                        Or (cell.Value) = "Stage 1c - CB1 Approval" _
                        Or (cell.Value) = "Stage 2a - TIM and Request Impacts" _
                        Or (cell.Value) = "Stage 2b - Track Impacts" _
                        Or (cell.Value) = "Stage 2c - Consolidation" _
                        Or (cell.Value) = "Stage 3a - Post CB2 Action Closing" _
                        Or (cell.Value) = "Stage 3b - CSLT Approval" _
                        Or (cell.Value) = "Stage 3c - Finance Approval" _
                        Or (cell.Value) = "Stage 4a - Request PIP" _
                        Or (cell.Value) = "Stage 4b - Track PIP" _
                        Or (cell.Value) = "Stage 5a - Track PCRIN" _
                        Or (cell.Value) = "Stage 5b - Implementation Consolidation" _
                        Or (cell.Value) = "Stage 6 - Closed" Then
                Else
                   sht2.Cells(r, 1).Value = cell.Address
                   sht2.Cells(r, 2).Value = (cell.Value)
                   sht2.Cells(r, 3).Value = "This is not an official ICMS stage. ex: 'Stage 5b - Implementation Consolidation'"
                   r = r + 1
                End If
            Next

        Set colrg = Range("D3:D" & lastr)
        c = 1
            For Each cell In colrg
'## out of memory error on the following line
                    If (cell.Value) = "Kiled" Or (Cells.Value) = "Archived" Then
                        c = c + 1
                        ElseIf tbl.Cells(c, 3).Value = "Stage 1a - Director Approval" _
                                    Or tbl.Cells(c, 3).Value = "Stage 1b - PMO Approval" _
                                    Or tbl.Cells(c, 3).Value = "Stage 1c - CB1 Approval" _
                                    Or tbl.Cells(c, 3).Value = "Stage 2a - TIM and Request Impacts" _
                                    Or tbl.Cells(c, 3).Value = "Stage 2b - Track Impacts" _
                                    Or tbl.Cells(c, 3).Value = "Stage 2c - Consolidation" _
                                    Or tbl.Cells(c, 3).Value = "Stage 3a - Post CB2 Action Closing" _
                                    Or tbl.Cells(c, 3).Value = "Stage 3b - CSLT Approval" _
                                    Or tbl.Cells(c, 3).Value = "Stage 3c - Finance Approval" Then
                                cell.Value = "Pre-Approval"
                                c = c + 1
                            ElseIf tbl.Cells(c, 3).Value = "Stage 4a - Request PIP" _
                                        Or tbl.Cells(c, 3).Value = "Stage 4b - Track PIP" _
                                        Or tbl.Cells(c, 3).Value = "Stage 5a - Track PCRIN" _
                                        Or tbl.Cells(c, 3).Value = "Stage 5b - Implementation Consolidation" _
                                        Or tbl.Cells(c, 3).Value = "Stage 6 - Closed" Then
                                    cell.Value = "Approved"
                                    c = c + 1
                                Else
                                    sht2.Cells(r, 1).Value = cell.Address
                                    sht2.Cells(r, 2).Value = (cell.Value)
                                    sht2.Cells(r, 3).Value = "This PCRs Stage is not correct so the Status cannot be determined"
                                    r = r + 1
                                    c = c + 1
                    End If
                Next
Exit Sub

DataSheetError:
    errbox = MsgBox("There is an error witht the main data tab. Either it has been" & Chr(13) & "deletod or renamed." & Chr(13) & Chr(13) & "Please ensure the main tab is present and named 'DataSheet'", vbOKOnly, "Data Tab Error")
    Exit Sub

DiscrepancySheetError:
    ThisWorkbook.Sheets.Add After:=Sheets(Worksheets.Count), Count:=1, Type:=xlWorksheet
    ActiveSheet.Name = "DiscrepancyReport"
    Resume Next

End Sub

ありがとう！