Efficient Copy/Paste

[William Benson]

Hi, I recently wrote someone a solution as shown below. The OP wanted to
compare values in col A on two sheets -- Source and Dest. If the values were
equal on any given row, he wanted contents from Columns I and K to be copied
from Source to Dest for that row (to I and K, respectively).

Because the ranges copied from are staggered and the ranges copied to are
non-contiguous, I saw no way to add the cells to a range for bulk
copy/paste -- so of course the solution takes a long time (the user said
about 35,000 rows to check, but I am not sure how many cop/pastes would have
resulted)

Can the code be made more efficient in this case?

Thanks!

Sub CopyIdenticals()
Dim rngSourceCompare As Range
Dim c As Range

On Error Resume Next
Set rngSourceCompare = Application.InputBox _
(prompt:="Select all cells in col A for comparison", _
Type:=8)
If rngSourceCompare Is Nothing Then
Exit Sub
End If

If rngSourceCompare.Parent.Name <> "Source" Then
MsgBox "Only choose col A values on sheet 'Source'"
Exit Sub
End If

On Error GoTo 0
Application.ScreenUpdating = False
For Each c In rngSourceCompare

If c.Value = Sheets("Dest").Range(c.Address).Value Then
c.Offset(0, 8).Copy 'note: Col I
Sheets("Dest").Range("I" & c.Row).PasteSpecial _
Paste:=xlPasteValues
c.Offset(0, 10).Copy 'note: Col K
Sheets("Dest").Range("K" & c.Row).PasteSpecial _
Paste:=xlPasteValues
End If
Next c
Application.ScreenUpdating = True
End Sub

 

[Tom Ogilvy]

Sub CopyIdenticals()
Dim rngSourceCompare As Range
Dim rngDest as Range
Dim v1, v2, v1IJK, v2IJK
Dim i as Long
On Error Resume Next
Set rngSourceCompare = Application.InputBox _
(prompt:="Select all cells in col A for comparison", _
Type:=8)
If rngSourceCompare Is Nothing Then
Exit Sub
End If

If rngSourceCompare.Parent.Name <> "Source" Then
MsgBox "Only choose col A values on sheet 'Source'"
Exit Sub
End If

On Error GoTo 0
Application.ScreenUpdating = False
v1 = rngSourceCompare.Value
rngDest = Worksheets("Dest").Range(rngsourceCompare.Address)
v2 = rngDest.Value
v1IJK = rngSourceCompare.Offset(0,8).Resize(,3).Value
v2IJK = rng.Dest.Offset(0,8).Resize(,3).Formula
for i = lbound(v1,1) to ubound(v1,1)
if v1(i,1) = v2(i,1) then
v2IJK(i,1) = v1IJK(i,1)
v2IJK(i,3) = v1IJK(i,3)
end if
Next
rngDest.Offset(0,8).Resize(,3).Formula = v2IJK
Application.ScreenUpdating = True
End Sub

 

[Tom Ogilvy]

Probably ought to set calculation to manual as well.

 

[William Benson]

Couple typos: rng.Dest should be rngDest, and since rngDest is a range,
needed to use "Set" on the code line you used to assign it. Seems like you
wrote this from your head?? I just wish I understood it Tom :-(

Once I cleared up these, the improved performance was AMAZING!!! Wow.
Thanks,

Bill

 

[William Benson]

By George I think I've got it.

So, you assigned all of the destination cells first to v2IJK, a N x 3
array.

v2IJK = rngDest.Offset(0, 8).Resize(, 3).Formula

to preserve the cells that should not be over-written.


and then, you change only the elements of the array that deserve to be
changed.

Then you just write back the contents of the revised array to the Dest
range.

rngDest.Offset(0, 8).Resize(, 3).Formula = v2IJK

Miraculous!

Thanks a million!