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
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