ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Discussion (Misc queries) (https://www.excelbanter.com/excel-discussion-misc-queries/)
-   -   Compare col and match then copy and paste (https://www.excelbanter.com/excel-discussion-misc-queries/177330-compare-col-match-then-copy-paste.html)

saman110 via OfficeKB.com

Compare col and match then copy and paste
 
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

--
Message posted via http://www.officekb.com


Dave Peterson

Compare col and match then copy and paste
 
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" wrote:

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

--
Message posted via http://www.officekb.com


--

Dave Peterson

saman110 via OfficeKB.com

Compare col and match then copy and paste
 
Thank you. It worked well.

Dave Peterson wrote:
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]
--
Message posted via http://www.officekb.com



--
Message posted via http://www.officekb.com



All times are GMT +1. The time now is 11:28 AM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
ExcelBanter.com