Rewrite code to use less memory

[Karl Gustaf Karsten]

I posted this problem a few days ago, here.
Now that I understand the problem a little better, I’m posting it again (hopefully a little clearer)

I have a macro that performes a simple task. It matches rows from sheet2 with rows in sheet1 if their respective value in column A match.
However, when I have a lot of data, I get a memory error and can't run the code.

This is an example of a smal dataset (the line that causes the error):

Sub Merge_Data()
'Merges the data (rows) with identical Unique-ID - Import from Sheet2 into Sheet1.

Application.ScreenUpdating = False
        
        Temp = "" & "I" & "1:" & Cells(10, 13).Address
        Sheets("Sheet1").Range(Temp).FormulaR1C1 = _
                "=OFFSET(Sheet2!R1C[" & -8 & "],MATCH(RC1,Sheet2!R1C1:R" & 10 & "C1,0)-1,0)"

Application.ScreenUpdating = True
      
End Sub

My question: Is there a way to break this up into several separate operations?
E.g. first find matches for row 1 and 2, then row 3 and 4, etc.

I’m stuck, so I appreciate all feedback!

[InvisibleMan]

That code extract works for me and generates

=OFFSET(Sheet2!A$1,MATCH($A1,Sheet2!$A$1:$A$10,0)-1,0)

in cell I1, copied across and down to cell M10.

[xladept]

Hi Karl,

Try this:

Sub Karl(): Dim w1 As Worksheet, w2 As Worksheet, r As Long, UID As String
        Set w1 = Sheets("Sheet1"): Set w2 = Sheets("Sheet2")
         
        With CreateObject("Scripting.Dictionary")
        For r = 1 To w2.Range("A" & Rows.count).End(xlUp).Row
            UID = w2.Range("A" & r): .Item(UID) = r: Next r
            
For r = 1 To w1.Range("A" & Rows.count).End(xlUp).Row: UID = w1.Range("A" & r)
        If .Exists(UID) Then _
        w1.Range("I" & r).Resize(1, 5).Value = w2.Range("A" & .Item(UID)).Resize(1, 5).Value
        Next r
        End With
End Sub

[Karl Gustaf Karsten]

Wow!
That looks great, tested it now and I think it's exactly what I'm looking for (and much faster than what I had)
Thank you very much, Xladept

My sheets may have more rows and columns, is there any reason why this is not a good way to generalize it?

Sub Karl(): Dim w1 As Worksheet, w2 As Worksheet, r As Long, UID As String, LC1 As Long, LC2 As Long
        Set w1 = Sheets("Sheet1"): Set w2 = Sheets("Sheet2")
        
        LC1 = w2.Cells(1, Columns.Count).End(xlToLeft).Column
        LC2 = w1.Cells(1, Columns.Count).End(xlToLeft).Column
        ColLetter = GetColumnLetter(LC2 + 2)
         
        With CreateObject("Scripting.Dictionary")
        For r = 1 To w2.Range("A" & Rows.Count).End(xlUp).Row
            UID = w2.Range("A" & r): .Item(UID) = r: Next r
            
For r = 1 To w1.Range("A" & Rows.Count).End(xlUp).Row: UID = w1.Range("A" & r)
        If .Exists(UID) Then _
        w1.Range("" & ColLetter & r).Resize(1, LC2).Value = w2.Range("A" & .Item(UID)).Resize(1, LC2).Value
        Next r
        End With
End Sub
Function GetColumnLetter(colNum As Long) As String
    Dim vArr
    vArr = Split(Cells(1, colNum).Address(True, False), "$")
    GetColumnLetter = vArr(0)
End Function

[xladept]

Hi Karl,

I kept the 1's with thr 1's and the 2's with the 2's and got rid of that Column letter:

Sub KarlK(): Dim w1 As Worksheet, w2 As Worksheet, r As Long, UID As String, LC1 As Long, LC2 As Long
        Set w1 = Sheets("Sheet1"): Set w2 = Sheets("Sheet2")
        LC2 = w2.Cells(1, Columns.count).End(xlToLeft).column
        LC1 = w1.Cells(1, Columns.count).End(xlToLeft).column
         
        With CreateObject("Scripting.Dictionary")
        For r = 1 To w2.Range("A" & Rows.count).End(xlUp).Row
            UID = w2.Range("A" & r): .Item(UID) = r: Next r
            
For r = 1 To w1.Range("A" & Rows.count).End(xlUp).Row: UID = w1.Range("A" & r)
        If .Exists(UID) Then _
        w1.Cells(r, LC1 + 2).Resize(1, LC2).Value = w2.Range("A" & .Item(UID)).Resize(1, LC2).Value
        Next r
        End With
End Sub

[Karl Gustaf Karsten]

Perfect! This is beautiful

Thanks again, this is very very helpful!

[xladept]

Hi Karl,

Here's a quicker version for your big file:

Sub KarlQ(): Dim w1 As Worksheet, w2 As Worksheet, r As Long
Dim UID As String, LC1 As Long, LC2 As Long, Q1, Q2, n As Long
        Set w1 = Sheets("Sheet1"): Set w2 = Sheets("Sheet2")
        LC2 = w2.Cells(1, Columns.count).End(xlToLeft).column
        LC1 = w1.Cells(1, 1).End(xlToRight).column
    Q2 = w2.UsedRange: w1.UsedRange.Offset(0, LC1).ClearContents
                  Q1 = w1.UsedRange.Resize(, LC1 + 1 + LC2)
         
        With CreateObject("Scripting.Dictionary")
        For r = 1 To UBound(Q2, 1)
        UID = Q2(r, 1): .Item(UID) = r: Next r
            
For r = 1 To UBound(Q1, 1): UID = Q1(r, 1)
            If .Exists(UID) Then
For n = 1 To LC2: Q1(r, LC1 + n + 1) = Q2(.Item(UID), n): Next n
            End If
        Next r
        End With:   w1.UsedRange.Resize(, LC1 + 1 + LC2) = Q1
End Sub

[xladept]

You're welcome and thanks for the rep!

[Karl Gustaf Karsten]

Hi, thanks again!

I'm sure it's faster but I get a memory error on this line (on a laptop)

Q1 = w1.UsedRange.Resize(, LC1 + 1 + LC2)

However, you've already reduced my run time from hours to seconds - And I'm very exited about that

I'll try it again tomorrow on a desktop.

[xladept]

Hi Karl,

If you need to rerun it, you'll want this code (or the quick code):

Sub KarlKLG(): Dim w1 As Worksheet, w2 As Worksheet, r As Long, UID As String, LC1 As Long, LC2 As Long
        Set w1 = Sheets("Sheet1"): Set w2 = Sheets("Sheet2")
        LC2 = w2.Cells(1, Columns.count).End(xlToLeft).column
        LC1 = w1.Cells(1, 1).End(xlToRight).column
        w1.UsedRange.Offset(0, LC1).ClearContents
        With CreateObject("Scripting.Dictionary")
        For r = 1 To w2.Range("A" & Rows.count).End(xlUp).Row
            UID = w2.Range("A" & r): .Item(UID) = r: Next r
            
For r = 1 To w1.Range("A" & Rows.count).End(xlUp).Row: UID = w1.Range("A" & r)
        If .Exists(UID) Then _
        w1.Cells(r, LC1 + 2).Resize(1, LC2).Value = w2.Range("A" & .Item(UID)).Resize(1, LC2).Value
        Next r
        End With
End Sub

[xladept]

Hi Karl,

Thanks for the rep!

How big are your worksheets?

Let me know - I wonder if the Array size is limited?

[Karl Gustaf Karsten]

Hi again,

Sheet1 has 140 000 rows and goes to column DA
Sheet2 has 250 000 rows and goes to column AK

I might need to work with bigger sheets in the future, but not significantly bigger, so I think this will do it

I ran the quick code again and got the out of memory error, here:

Q2 = w2.UsedRange

I timed Sub KarlK() and Sub KarlKLG() and both used 22 seconds, is the latter better?

[xladept]

The only difference in the two routines is that you can run the second one over and over - the first one would keep growing the LC1!

* I wonder if your configuration is adequate? Do you have your core partitioned or are you short on RAM? I've processed larger books than that - I have 4GB of RAM and 367GB of free space.

** but 22 seconds? that code certainly fulfills the requirement

[Karl Gustaf Karsten]

Ok, thats good to know.

I'm not sure about the configuration at all - My (work) computer has access to my partition (40GB free) through a network, and I do not have access to the C: drive. System information says 8GB of RAM though.

Anyway, thanks again for taking the time to help!
It makes this project a lot easier for me so I really appreciate it

[xladept]

Well - the "slow" program satisfies the "use less memory" criterion - glad it worked out