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 |
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 |
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