Macro keep making excel go to non responding.

[gareth7412]

Hi

I have this macro and it works OK with a small amount of data but now I have over 40,000 rows of data I need to go through and it keeps coming up not responding. Is there anyone way I can make it so it dont keep crashing?

Dim newRow As Range, oldRow As Range, shNew As Worksheet, shOld As Worksheet, match As Boolean
For Each shNew In Sheets
    If LCase(shNew.Name) Like "new*" Then Exit For
Next
For Each shOld In Sheets
    If LCase(shOld.Name) Like "old*" Then Exit For
Next

For Each newRow In shNew.UsedRange.Rows
    match = False
    For Each oldRow In shOld.UsedRange.Rows
        If oldRow.Columns("F") = newRow.Columns("F") _
        And oldRow.Columns("J") = newRow.Columns("J") _
        And oldRow.Columns("K") = newRow.Columns("K") Then
            If Application.CountA(oldRow.Resize(1, 4)) = 0 Then
                ' delete new record from new sheet.
                newRow.EntireRow.Clear
                match = True
                Exit For
            Else
                ' paste new record on top of the matching row in old sheet.
                newRow.Copy
                shOld.Paste oldRow.Cells(1)
                match = True
                Exit For
            End If
        End If
    Next
    If Not match Then
        ' paste new record at bottom
        With shOld
            newRow.Copy
            shOld.Paste .UsedRange.Cells(.UsedRange.Count).EntireRow.Cells(1).Offset(1, 0)
        End With
    End If
Next

shOld.Name = "old " & Format(Now, "mm-dd-yyyy") & "."
shNew.Name = "New " & Format(Now, "mm-dd-yyyy") & "."
End Sub

[Mumps1]

It would be easier to help and test possible solutions if you could attach a copy of your file. Explain in detail what you want to do referring to specific
cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary). See the yellow banner at the top of this page for instructions to attach a file.

[Marc L]

it keeps coming up not responding. Is there anyone way I can make it so it dont keep crashing?

Hi, do not confuse crashing and not responding as that just means Excel is busy with the execution of a VBA procedure …

Just try desactivating ScreenUpdating, EnableEvents, …

[gareth7412]

I may be confusing it marc.

What it is I have this workbook of which has data that I have used and unused data.

In the sheet called OLD that is the data that I use and when I use it I cut and paste the data elsewhere leaving the cells blank. This is shown in rows 6 & 7.

I then do a new download of which downloads all the data that ive used and new data.

What im trying to do is compare the worksheets and if there is no data in coulmns A-D on a particular row in sheet called OLD then I need that row completely deleting from the new sheet. The data in columns J & K in both sheets will be exactly the same as they are unique so that would probably be best way of matching and deleting.

There will be upto 50,000 entries in the workbooks.

See attachment.

MARC:-Just try desactivating ScreenUpdating, EnableEvents, How do I do that?

[Marc L]

if there is no data in coulmns A-D on a particular row in sheet called OLD then I need that row completely deleting from the new sheet. The data in columns J & K in both sheets will be exactly the same as they are unique

According to your attachment a VBA demonstration for starters :

Sub Demo1()
          Const D = "&"" ""&", K = 11
            Dim Rg As Range, V, W, Rc As Range, X, R&
    With Sheet3.[A1].CurrentRegion.Columns
        If Application.CountBlank(.Item(1)) Then
            Set Rg = Sheet4.[A1].CurrentRegion
            V = Rg.Parent.Evaluate(Rg.Columns(10).Address & D & Rg.Columns(K).Address)
            W = .Parent.Evaluate(.Item(10).Address & D & .Item(K).Address)
            Application.ScreenUpdating = False
        For Each Rc In .Item(1).SpecialCells(4)
            X = Application.Match(W(Rc.Row, 1), V, 0)
            If IsNumeric(X) Then R = R + 1: Rg(X, K).ClearContents: W(Rc.Row, 1) = Empty
        Next
        If R Then
            Rg.Sort Rg.Cells(K), 1, Header:=1
            Rg.Parent.Rows(Rg.Rows.Count - R + 1).Resize(R).Delete
        End If
            Application.ScreenUpdating = True
            Set Rg = Nothing
        End If
    End With
End Sub 

► Do you like it ? ► ► So thanks to click on bottom left star icon « ★ Add Reputation » ! ◄ ◄

[gareth7412]

Give me a day or so to test but looks like it sorted.