VBA Code causes error: “There isn't enough memory to complete this action.”

[dubumochi]

have a consolidator tool that consolidates data from different worksheets. It can handle up to 1 million rows. However, when I click the button to check duplicates, there's an error that says "There isn't enough memory to do this action." I noticed that this error only happens when this macro runs. Please excuse the bad practice code as I am new to programming and this is what currently works right now. This works for less than 100 rows but when it starts to reach 100+, it ends up freezing and racks up memory. Is there anyway I can clean this code properly while still maintaining the functionality? T

This is how it works:

| Employee ID | Status |

E100 Deactivated

E100 Activated


Turns into:

| Employee ID | Status | Status |

E100 Deactivated Activated

Sub mergeCategoryValues()
Dim lngRow As Long
Dim rngPrimaryKey As Range

Application.ScreenUpdating = False
Application.EnableEvents = False


'This is using activesheet, so make sure your worksheet is
' selected before running this code.
Sheets("Consolidated").Activate

With ActiveSheet

     Set rngPrimaryKey = .Range("A:Z").Find("Full Name")

    Dim columnToMatch As Integer
    columnToMatch = rngPrimaryKey.Column

    'Figure out the last row
    lngRow = .Cells(1000000, columnToMatch).End(xlUp).Row

    .Cells(columnToMatch).CurrentRegion.Sort key1:=.Cells(columnToMatch), Header:=xlYes

    For Each Cell In ActiveSheet.UsedRange
    If Cell.Value <> "" Then
    Cell.Value = Trim(Cell.Value)
    End If
    Next Cell

    'Loop through each row starting with last and working our way up.
    Do

        If .Cells(lngRow, columnToMatch) = .Cells(lngRow - 1, columnToMatch) Then

            'Loop through columns B though P
            For i = 1 To 1000 '1000 max (?)

                'Determine if the next row up already has a value. If it does leave it be
                '   if it doesn't then use the value from this row to populate the next
                '   next one up.

                If .Cells(lngRow - 1, i).Value <> "" Then 'if not blank
                    If .Cells(lngRow - 1, i).Value <> .Cells(lngRow, i).Value Then 'if previous value is not equal to current value
                    ''''''
                    'INSERT NEW COLUMN HERE
                         If i <> 1 Then 'if column is not "Data Source"
                                If .Cells(lngRow, i).Value <> "" Then
                                 Cells(lngRow - 1, i + 1).EntireColumn.Insert
                                .Cells(lngRow - 1, i + 1).Value = .Cells(lngRow, i).Value
                                'INSERT COLUMN NAME
                                .Cells(1, i + 1).Value = .Cells(1, i).Value
                            End If
                        Else
                        .Cells(lngRow - 1, i).Value = .Cells(lngRow - 1, i).Value & "; " & .Cells(lngRow, i).Value

                    End If
                    Else
                   'Do Nothing
                   End If
              End If
            Next i

            'Now that we've processed all of the columns, delete this row
            '   as the next row up will have all the values
            .Rows(lngRow).Delete
        End If

        'Go to the next row up and do it all again.
        lngRow = lngRow - 1
    Loop Until lngRow = 1
End With


With ActiveWindow
    .SplitColumn = 1
    .SplitRow = 0
End With

ActiveWindow.FreezePanes = True

Worksheets("Consolidated").Range("A:Z").Columns.AutoFit

Application.ScreenUpdating = True
Application.EnableEvents = True

If Err <> 0 Then
    MsgBox "An unexpected error no. " & Err & ": " _
    & Err.Description & " occured!", vbExclamation
End If

End Sub