Move entire row to another sheet based on dynamic cell value

jiveass1960

New Member
Joined
Aug 20, 2019
Messages
19
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
 
No. Sorry. Let me try to explain better. The script you built adds all the rows on the shipment sheet and tries to match them with the corresponding row on the master sheet. There should never be an entry on the shipment sheet that doesn't exist on the master but yesterday there was. I'm looking to setup a warning or some feed back when this occurs. For example, there were 60 records to be updated from shipping to master but when I ran the script and then checked the count of rows updated manually, only 48 were updated. When the amount of rows added to the scripting dictionary is greater than the number of rows updated on master, that means that the master table is missing records or has incorrect info in the master table. I hope that makes sense and thank you!!
 
Upvote 0

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
But you only update the record if col Q is blank.
 
Upvote 0
Correct, Q is the ship date. So if Sheet(Shipment).Row.A matches Sheet(Master).Row.O then update Sheet(Master).Row.Q-U. In a perfect world, any record in Sheet(Shipment) should always match to a record in Sheet(Master) as Master is where our products are stored when they are created. Shipment is where our shipment info is placed via Barcode Scanner and then your script matches and copies. Yesterday, there were 60 shipments but when I ran the script only 48 updated. Meaning there were 12 errors on the Master Table. The user wouldn't have known this though as there is no error catching/feedback. That is what i'm curious if it could be caught or warned when there is a mismatch. I have a msgbox pop up before the confirmation which runs your script stating how many records are about to be updated but that is just a count of the number of rows on shipment before processing. I'm wondering if logic could be used to say, there are 60 records but only 48 matches. do you wish to proceed or stop and do not proceed. The language could be whatever but if the scripting dictionary has more records than matches, something is wrong and requires manual review.
 
Upvote 0
Ok, how about
VBA Code:
Sub ProcessShipping()
   
   With Application
      .Interactive = False
      .Calculation = xlCalculationManual
      .ScreenUpdating = False
   End With
   
   Dim Cl As Range
   Dim Dic As Object
   Dim i As Long
   
   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 Not Dic.exists(Cl.Value) Then i = i + 1
      Next Cl
   End With
   
   If i > 0 Then
      If MsgBox(i & " Records no found in Master" & vbLf & "Do you want to continue?", vbYesNo) = vbNo Then Exit Sub
   End If
   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
 
Upvote 0
This is a great start. Some things I encountered:

1) There were only 60 records to import but the newly added prompt returned 162 to be updated. Now there is a total of 222 records in master and if you subtract 60 from it, you get 162. So i'm guessing this is just a simple math problem?

2) When I clicked no to the "Do you want to continue" msgbox, the sub ended but the cursor is stuck as a hourglass as if it is still running or doing something. Not sure how to explain this but even in VB, I stopped the process and the cursor is still an hourglass.

Thank you!!!
 
Upvote 0
How about
VBA Code:
Sub ProcessShipping()
   
   With Application
      .Interactive = False
      .Calculation = xlCalculationManual
      .ScreenUpdating = False
   End With
   
   Dim Cl As Range
   Dim Dic As Object
   Dim i As Long
   
   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 Dic.exists(Cl.Value) Then i = i + 1
      Next Cl
   End With
   
   If i < Dic.Count Then
      If MsgBox("There were some records not found in Master" & vbLf & "Do you want to continue?", vbYesNo) = vbNo Then GoTo Xit
   End If
   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
Xit:
   With Application
      .Interactive = True
      .Calculation = xlCalculationAutomatic
   End With
End Sub
 
Upvote 0
That worked well!!! You're a genius. Last question or request, I love how you only prompt the msgbox when there is a mismatch. Is it at all possible to pass the number of mismatches or even better yet, a list of all the ones that did not match? Please feel free to tell me no, hahaha. You are appreciated!
 
Upvote 0
This will tell you how many
VBA Code:
      If MsgBox("There were " & Dic.Count - i & " records not found in Master" & vbLf & "Do you want to continue?", vbYesNo) = vbNo Then GoTo Xit
Whilst it would be possible to get a list of the values not found, it would be far simpler to use conditional formatting to highlight anything on the shipment sheet that's not on the master.
 
Upvote 0
I thought of that but I am completely hiding tabs and locking as much as I can to prevent the users from messing things up. For me, it doesn't need to be dummy-proof but end users break things far more than children LOL. Thank you so much Fluff! You are appreciated!
 
Upvote 0
You're welcome & thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,506
Messages
6,114,027
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top