Making a If True Double Loop Copy Special Paste Faster

[Hmerman]

Hello,
Hope you are well.

I have code that looks on Sheet 7 and Sheet 18 for a cells thats values are equal. Then pastes contiguous and non contiguous values in the same row as the equal cell in Sheet 7 to Sheet 18.

It takes a very long time. Can someone please help to make it faster?

<code>
Dim varResponse As String
Dim i As Long, x As Long

varResponse = MsgBox("Transfer Info to Inventory", vbYesNo, "Selection")
​

If varResponse <> vbYes Then Exit Sub
​

Application.ScreenUpdating = False

With Sheet18​

lastLookup = Sheet7.Range("C" & .Rows.Count).End(xlUp).row​

lastrow = .Range("C" & .Rows.Count).End(xlUp).row​

For i = 2 To lastrow​

For x = 2 To lastLookup​

If (Sheet7.Cells(x, 3) = .Cells(i, 3).Value) Then​

Sheet7.Cells(x, 2).Copy​

.Cells(i, 6).PasteSpecial xlPasteValues​

Sheet7.Cells(x, 4).Copy​

.Cells(i, 7).PasteSpecial xlPasteValues​

Sheet7.Cells(x, 8).Copy​

.Cells(i, 8).PasteSpecial xlPasteValues​

Sheet7.Cells(x, 12).Copy​

.Cells(i, 9).PasteSpecial xlPasteValues​

Sheet7.Cells(x, 14).Copy​

.Cells(i, 10).PasteSpecial xlPasteValues​

Sheet7.Cells(x, 15).Copy​

.Cells(i, 11).PasteSpecial xlPasteValues​

Sheet7.Cells(x, 16).Copy​

.Cells(i, 12).PasteSpecial xlPasteValues​

Sheet7.Cells(x, 17).Copy​

.Cells(i, 13).PasteSpecial xlPasteValues​

Sheet7.Cells(x, 18).Copy​

.Cells(i, 14).PasteSpecial xlPasteValues​

Sheet7.Cells(x, 19).Copy​

.Cells(i, 15).PasteSpecial xlPasteValues​

Sheet7.Cells(x, 20).Copy​

.Cells(i, 16).PasteSpecial xlPasteValues​

Sheet7.Cells(x, 21).Copy​

.Cells(i, 17).PasteSpecial xlPasteValues​

Sheet7.Cells(x, 22).Copy​

.Cells(i, 18).PasteSpecial xlPasteValues​

Sheet7.Cells(x, 23).Copy​

.Cells(i, 19).PasteSpecial xlPasteValues​

Sheet7.Cells(x, 24).Copy​

.Cells(i, 20).PasteSpecial xlPasteValues​

End If​

Next​

Next
​

MsgBox "Complete!"


End With
Application.ScreenUpdating = True
</code>

Any advice or suggestion will be helpful.

Regards,
Herman

 

[Fluff]

How about

Sub chk()

   Dim varResponse As String
   Dim i As Long, x As Long
   Dim Var1 As Variant
   
   varResponse = MsgBox("Transfer Info to Inventory", vbYesNo, "Selection")
   If varResponse <> vbYes Then Exit Sub
   
   Application.ScreenUpdating = False
   With Sheet18
      lastlookup = Sheet7.Range("C" & .Rows.Count).End(xlUp).Row
      LastRow = .Range("C" & .Rows.Count).End(xlUp).Row
      For x = 2 To lastlookup
         Var1 = Application.Match(Sheet3.Range("C" & x).Value, .Columns(3), 0)
         If Not IsError(Var1) Then
            .Cells(Var1, 6).Value = Sheet7.Cells(x, 2).Value
            .Cells(Var1, 7).Value = Sheet7.Cells(x, 4).Value
            .Cells(Var1, 8).Value = Sheet7.Cells(x, 8).Value
         End If
      Next
      MsgBox "Complete!"
      
      
   End With
   Application.ScreenUpdating = True
End Sub

I've done the 1st 3 values to be copied, you simply need to do the rest in a similar manner.

 

[Hmerman]

Thanks.

If I use the .value in my code it removes the values from the cells and places them in the target cells. So I cannot use that as the info on Sheet 7 must stay in tact.

I will definitely try Application.Match as that looks like true brevity.

 

[Hmerman]

Using .Value does significantly quicken the code. But it won't fit with my project.

 

[Fluff]

My code should not be changing anything on sheet7, it just copies the value from sheet7 to sheet18

 

[Hmerman]

Sorry I was wrong. Your code works very very fast.

If I want to add the following logical questions, should I add them after iserror, like so:

<code>
<code>
If not IsError(Var1) and (Sheet7.Cells(x, 14).Value = vbNullString) And _

(Sheet7.Cells(x, 21).Value = vbNullString) then
​

</code>
</code>

 

[Fluff]

That should be fine.

 

[Hmerman]

I have been trying to add the following logic and extra loop to check whether the destination cell on Sheet18 is empty before placing the values in the cell.

<code>

lastrow = Sheet18.Range("C" & .Rows.Count).End(xlUp).row

For i = 2 To lastrow

If (.Cells(i, 6).Value = vbNullString) Then
​

...your code...

End if
​

Next
</code>

But it does not work. Is there a way to check that the destination cell is empty, before placing Sheet7 values in the cells?

Sorry if I am pushing it a bit.

 

[Fluff]

Try like this

      For x = 2 To lastlookup
         Var1 = Application.Match(Sheet3.Range("C" & x).Value, .Columns(3), 0)
         If Not IsError(Var1) Then
            If .Cells(Var1, 6).Value = "" Then .Cells(Var1, 6).Value = Sheet7.Cells(x, 2).Value
            If .Cells(Var1, 7).Value = "" Then .Cells(Var1, 7).Value = Sheet7.Cells(x, 4).Value
            If .Cells(Var1, 8).Value = "" Then .Cells(Var1, 8).Value = Sheet7.Cells(x, 8).Value
         End If
      Next

 

[Hmerman]

That worked beautifully.

Thank you very much. I appreciate it.