Move entire row to another sheet based on dynamic cell value

[jiveass1960]

Hello,

I'm trying to tweak a few different things to improve upon my current code. The current code works but seems extremely slow. Ultimately what it does is update a master sheet with shipping data when the temp sheet has a matching unique shipping ID on the master sheet.

Private Sub CommandButton1_Click()

Application.Interactive = False

Dim Cl As Range
Dim Dic As Object
Set Dic = CreateObject("scripting.dictionary")
With Sheets("Shipment")
For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
Dic.Item(Cl.Value) = Cl.Offset(, 1).Resize(, 5)
Next Cl
End With
With Sheets("Master")
For Each Cl In .Range("O2", .Range("O" & Rows.Count).End(xlUp))
If IsEmpty(Cl.Offset(, 2).Value) Then
Cl.Offset(, 2).Resize(, 5) = Dic.Item(Cl.Value)
End If
Next Cl
End With
Sheets("Shipment").Range("A2:A100").ClearContents
Sheet4.Activate
Application.Interactive = True
End Sub

This works but it takes quite a while (30-45 seconds) which isn't the worst thing in the world. Why I'm posting this is to find out if there is a better way of accomplishing this? I found this code which looked promising but it uses a static value "Done". I need this value to be dynamic as they matching would be based on the shipping ID's that are unique. The user who wrote this was trying to match two sheets(sheet1 & sheet2) and when there is a match, move the row to a new sheet (sheet3). Here is what I need to figure out. I need to compare sheet(Shipment), column A with sheet(Master) column O. When there is a match, copy sheet(Shipment), matching row (column B thru F) to sheet(Master), matching row (column Q thru U) and then clear the row that was copied from sheet(Shipment).


Sub Test()

Dim xRg As Range
Dim yRg As Range
Dim I As Long
Dim J As Long

I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet3").UsedRange.Rows.Count
secRow = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet3").UsedRange) = 0 Then J = 0
End If

Set xRg = Worksheets("Sheet1").Range("B2:B100")
Set yRg = Worksheets("Sheet2").Range("C1:C" & secRow)

On Error Resume Next
Application.ScreenUpdating = False
Dim M As Long
Dim N As Long

For N = 1 To xRg.Count
For M = 1 To yRg.Count
If CStr(xRg(N).Value) = CStr(yRg(M).Value) Then
yRg(M).EntireRow.Copy Destination:=Worksheets("Sheet3").Range("A" & J + 1)
yRg(M).EntireRow.Delete
If CStr(xRg(N).Value) = CStr(yRg(M).Value) Then
N = N - 1
End If
J = J + 1
End If
Next

Next

Application.ScreenUpdating = True
End Sub

 

[Fluff]

That shouldn't cause a problem, but you can try, at the start of the code

   With Application
      .Interactive = False
      .Calculation = xlCalculationManual
      .ScreenUpdating = False
   End With

and at the end

   With Application
      .Interactive = True
      .Calculation = xlCalculationAutomatic
   End With

 

[jiveass1960]

I'll give that a shot. Anything wrong with the little change i made to prevent the script from deleting existing entries when running? Originally after using it, I noticed that every time it ran it would update the new records but delete or overwrite any previous entries so I added the first and third row:

If IsEmpty(Cl.Offset(, 2).Value) Then
Cl.Offset(, 2).Resize(, 5) = Dic.Item(Cl.Value)
End If

There may be a better way of handling that than what I did.

 

[Fluff]

That's fine.

 

[jiveass1960]

Genius! Seriously, it happens so quickly now, it isn't even noticeable. Before you would have the mouse icon as a spinning circle and in the bottom left corner, it would flash "Calculating" dozens and dozens of times. Now it is lightning quick! I'll post the final code below just in case you see something else that should be tweaked. I really appreciate your continued support on this. Thank you.

Sub ProcessShipping()

With Application
    .Interactive = False
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With

Dim Cl As Range
Dim Dic As Object
  
Set Dic = CreateObject("scripting.dictionary")
With Sheets("Shipment")
    For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    Dic.Item(Cl.Value) = Cl.Offset(, 1).Resize(, 5)
    Next Cl
End With
   
With Sheets("Master")
    For Each Cl In .Range("O2", .Range("O" & Rows.Count).End(xlUp))
        If IsEmpty(Cl.Offset(, 2).Value) Then
        Cl.Offset(, 2).Resize(, 5) = Dic.Item(Cl.Value)
        End If
    Next Cl
End With

Sheets("Shipment").Range("A2:A100").ClearContents

With Application
    .Interactive = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

 

[jiveass1960]

OH, I noticed you set " .ScreenUpdating = False " but do not set it back to True. Is that OK?

 

[Fluff]

I never set it back to true as there is no need, it happens automatically once the code has finished.

 

[jiveass1960]

Well thank you again! Much appreciated.

 

[Fluff]

My pleasure & thanks for the feedback.

 

[jiveass1960]

Hi Fluff. I had one more question regarding this. I wrote a vba prompt before this runs that tells the user how many rows will be updated. This is just a basic count function. I ran it today and had 60 records to update but only 48 actually updated. I only determined this by manually counting and checking. Is there anyway to return to the user how many were actually updated or better yet, the number that couldn't be due to not matching? I'm not sure what would be more beneficial or even possible but thought I would ask the genius.

Thanks again.

 

[Fluff]

Are you saying that some records where not updated when they should have been?