Compare col and match then copy and paste

[saman110 via OfficeKB.com]

Hello,

The macro below works fine, but it has a draw back. When it compares col. A
from sheet 1 and 2, there shouldn't be any blank or empty cells in the range
otherwise it won't work.
Is there any way around this or mabe another macro that works with empty
cells?

thx.

here is the macro:

Sub CopyIDData()
Dim rng As Range
Dim rng1 As Range
Dim cell As Range
Dim res As Variant

With Worksheets("sheet1")
Set rng = .Range(.Range("A1"), .Range("A1").End(xlDown))
End With
With Worksheets("Sheet2")
Set rng1 = .Range(.Cells(1, 1), .Cells(1, 1).End(xlDown))
End With

For Each cell In rng
res = Application.Match(cell, rng1, 0)
If Not IsError(res) Then
rng1(res, 2).Resize(1, 1).Copy Destination:=cell.Offset(0, 1)
End If
Next
End Sub


'This is what it does without the blank cell in between the range.

Sheet 1

A B C D E F G
12
13
14

Sheet 2

D E F G
11 1 2 3
13 4 5 6
16 7 8 9
14 3 2 1

Result after Function;

Sheet 1

A B C D E F G
12
13 4 5 6
14 3 2 1

 

[Dave Peterson]

First, if there can be empty cells, I'd use xlup, not xldown:

Option Explicit
Sub CopyIDData()
Dim rng As Range
Dim rng1 As Range
Dim cell As Range
Dim res As Variant

With Worksheets("sheet1")
Set rng = .Range("A1", .cells(.rows.count,"A").end(xlup))
End With

With Worksheets("Sheet2")
Set rng1 = .Range("A1", .cells(.rows.count,"A").end(xlup))
End With

For Each cell In rng.cells
if trim(cell.value) = "" then
'skip it
else
res = Application.Match(cell, rng1, 0)
If Not IsError(res) Then
rng1(res, 2).Resize(1, 1).Copy Destination:=cell.Offset(0, 1)
End If
end if
Next cell
End Sub

(Untested, but it did compile.)

 

[saman110 via OfficeKB.com]

Thank you. It worked well.

First, if there can be empty cells, I'd use xlup, not xldown:

Option Explicit
Sub CopyIDData()
Dim rng As Range
Dim rng1 As Range
Dim cell As Range
Dim res As Variant

With Worksheets("sheet1")
Set rng = .Range("A1", .cells(.rows.count,"A").end(xlup))
End With

With Worksheets("Sheet2")
Set rng1 = .Range("A1", .cells(.rows.count,"A").end(xlup))
End With

For Each cell In rng.cells
if trim(cell.value) = "" then
'skip it
else
res = Application.Match(cell, rng1, 0)
If Not IsError(res) Then
rng1(res, 2).Resize(1, 1).Copy Destination:=cell.Offset(0, 1)
End If
end if
Next cell
End Sub

(Untested, but it did compile.)

Hello,

[quoted text clipped - 57 lines]