tranfering value if...

[sal21]

If is possible with a macro...
I have 2 sheets Source and Dest.
How can to tranfering the value from the column I an K of sheet Source
in to sheet Dest with this condition:

Note: the colunm A contain the idex from the 2 wbook.

If into column A of sheet Source is present the same value into column
A of sheet Dest copy from Source the value into column I an K and put
into refered cell of column I and K of Dest...
You must know that: Into official wbook the line from the 2 shhet are
approx 35.000 for each sheet


+-------------------------------------------------------------------+
|Filename: INSERT_VALUE.zip |
|Download: http://www.excelforum.com/attachment.php?postid=3789 |
+-------------------------------------------------------------------+

 

[William Benson]

Here is a solution... If you do not like having to select the original range
in Col A, let me know what you would prefer.


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

Application.ScreenUpdating = False
For Each c In rngSourceCompare
If c.Value = Sheets("Dest").Range(c.Address).Value Then
Sheets("Dest").Range("I" & c.Row).Copy Sheets("Source").Range("I" &
c.Row)
Sheets("Dest").Range("K" & c.Row).Copy Sheets("Source").Range("K" &
c.Row)
End If
Next c
Application.ScreenUpdating = True
End Sub

 

[William Benson]

Sorry, two problems with prior post:

1) I mixed up Source and Dest
2) I copied formulas, not values

Here is the correction:

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

 

[William Benson]

Tom Ogilvy gave me a much better, faster solution. Try this: I don't
understand it, but I am going to try harder to understand it!

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
Set rngDest = Worksheets("Dest").Range(rngSourceCompare.Address)
v2 = rngDest.Value
v1IJK = rngSourceCompare.Offset(0, 8).Resize(, 3).Value
v2IJK = rngDest.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