VBA Code causes error: "There isn't enough memory to complete this action"

Question

I 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. Is there anyway I can clean this code properly while still maintaining the functionality?

This is how it works:

| Employee ID | Status |  

E100             Deactivated 

E100            Activated

Turns into:

| Employee ID | Status | Status | 

  E100        Deactivated  Activated

Code:

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

        'Does this row match with the next row up accoding to the Job Number in Column A?
        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

Can you share an example to reproduce the problem. As for the one example you have provided, you don't need any macro to do that. Simple Functions like `Match`, `Index` are enough to achieve it. — Mikku, Jul 18 '19 at 05:29
@Mikku - The worksheet I'm using to test this is an AD Dump and I'm currently using a work laptop (not quite well versed in desensitizing that kind of data). The thing is, this works if it's rows 100 below but when it starts racking up data, it freezes and racks up memory. Is there a way to replace my for loop with Match and Index in VBA? They want us to automate this kind of thing so I'm at loss. — dubumochi, Jul 18 '19 at 05:39
The issue is probably because you are deleting each duplicated row in a loop. Try to clear the row instead and sort outside of the loop the get ride of the cleared rows. Though a better approach would be to load the values in an array and to use a `Scripting.Dictionary` to get ride of the duplicates. see https://stackoverflow.com/questions/36044556/quicker-way-to-get-all-unique-values-of-a-column-in-vba — Florent B., Jul 18 '19 at 07:17
Hi, guys. Thanks so much for the replies. I found out that what made this code harder to execute is the looping part. I should've used "UsedRange" to determine how many rows it should check. As for the adding columns part, we opted to just settle with concatenating the unique values using semicolon as separator. I used "UsedRange" for that part as well. If I will be given more time to fix this, I'll translate it to what you suggested @FlorentB. just really lacking time as this will be presented soon. — dubumochi, Jul 19 '19 at 06:16

score 0 · Answer 1 · answered Jul 18 '19 at 05:47

0

You can use a pivot table with a few mouse clicks that provides the same information value.

If you want to replace the numbers with the words, you can then copy the pivot table and perform a Find/Replace for each column.

answered Jul 18 '19 at 05:47

teylyn

34,374
4
53
73

VBA Code causes error: "There isn't enough memory to complete this action"

1 Answers1