4
\$\begingroup\$

I have 2 sheets with the exact format, 5 columns (Category1, Category2, Category3, Month, Amount) - "Temp" and "Source".

My goal is to copy the data from "Source" to a new sheet("Combined"), append the data from "Temp" but replace the rows that are matching on column C and D with the new rows from "Temp".

For now I have the following code that does the job:

Option Explicit

Sub Verify()
Dim c As Range
Application.ScreenUpdating = False
last3 = Sheets("Temp").Cells(Application.Rows.count, "A").End(xlUp).row
last4 = Sheets("Source").Cells(Application.Rows.count, "A").End(xlUp).row
last5 = Sheets("Combined").Cells(Application.Rows.count, "A").End(xlUp).row

' Clear Contents
Sheets("Combined").Range("A1:E" & last5).ClearContents

    Sheets("Temp").Range("G2").Formula = "=C2&D2"
    Sheets("Temp").Range("G2").Copy Destination:=Sheets("Temp").Range("G3:G" & last3)

    Sheets("Source").Range("G2").Formula = "=C2&D2"
    Sheets("Source").Range("G2").Copy Destination:=Sheets("Source").Range("G3:G" & last4)

    Sheets("Source").Range("H2").Formula = "=MATCH(G2,Temp!$G$2:$G$" & last3 & ",0)"
    Sheets("Source").Range("H2").Copy Destination:=Sheets("Source").Range("H3:H" & last4)

' Copy & Format Headers
Sheets("Temp").Range("A1:E1").Copy Destination:=Sheets("Combined").Range("A1")

' Copy All Data from Temp
Sheets("Temp").Range("A2:E" & last3).Copy Destination:=Sheets("Combined").Range("A2")

' Copy Selected Data from Source
    For Each c In Sheets("Source").Range("H2:H" & last4)
        If IsError(c) Then
          last5 = Sheets("Combined").Cells(Application.Rows.count, "A").End(xlUp).row
          Sheets("Source").Range("A" & c.row & ":E" & c.row).Copy Destination:=Sheets("Combined").Range("A" & last5 + 1)
        End If
    Next c

' Clean temp Columns
Sheets("Temp").Columns("G:G").Delete
Sheets("Source").Columns("G:H").Delete
Application.ScreenUpdating = True
End Sub

My problem with it is that is too slow(~15.000 rows). It freezes my excel with a white screen for a few minutes but in the end it works. I have tried using DoEvents but it is still really slow.

I am sure there a better way to achieve what I am looking for. Can someone please help me rewrite the VBA to speed it up? I would be grateful if I could at least get it not to freeze or increase the performance somehow.

\$\endgroup\$
3
\$\begingroup\$

If no one offered a suggestion, I have found a way to handle this. This makes it blazing fast:

Sub Verify()
Dim c As Range, last3 As Long, last4 As Long, last5 As Long
Dim wt As Worksheet, ws As Worksheet, wc As Worksheet
Set wt = Sheets("Temp"): Set ws = Sheets("Source"): Set wc = Sheets("Combined")
Application.ScreenUpdating = False

last3 = wt.Cells(Rows.Count, 1).End(xlUp).Row
last4 = ws.Cells(Rows.Count, 1).End(xlUp).Row
last5 = wc.Cells(Rows.Count, 1).End(xlUp).Row

wc.Cells.ClearContents ' Clear Contents
wt.Range("G2").Resize(last3 - 1, 1).Formula = "=C2&D2"
ws.Range("G2").Resize(last4 - 1, 1).Formula = "=C2&D2"
ws.Range("H2").Resize(last4 - 1, 1).Formula = "=MATCH(G2,Temp!$G$2:$G$" & last3 & ",0)"

' Copy & Format Headers
wt.Range("A1:E1").Copy wc.Range("A1")

' Copy All Data from Temp
wt.Range("A2:E" & last3).Copy wc.Range("A2")

' Copy Selected Data from Source
    For Each c In ws.Range("H2:H" & last4)
        If IsError(c) Then
          last5 = wc.Cells(Rows.Count, 1).End(xlUp).Row
    wc.Range("A" & last5 + 1).Resize(1, 5).Value = ws.Range("A" & c.Row).Resize(1, 5).Value
    End If
    Next c
' Clean temp Columns
Application.DisplayAlerts = False: wt.Columns("G").Delete: ws.Columns("G:H").Delete
Application.DisplayAlerts = True: Application.ScreenUpdating = True
End Sub
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.