S
saman110 via OfficeKB.com
Hello,
I have a macro that compares sheet1 col. A with sheet2 col.A and copies
sheet2 col.B matches into sheet1 col.B.
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, 2).Copy Destination:=cell.Offset(0, 1)
End If
Next
End Sub
----------
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
Now, What I want is same thing but when there is no matches to be found I
want the macro to find the closest number to sheet2 Col.A and copy its
adjusent to sheet1 Col.B.
I realy need this because it will save me tons of time.
Thank you.
I have a macro that compares sheet1 col. A with sheet2 col.A and copies
sheet2 col.B matches into sheet1 col.B.
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, 2).Copy Destination:=cell.Offset(0, 1)
End If
Next
End Sub
----------
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
Now, What I want is same thing but when there is no matches to be found I
want the macro to find the closest number to sheet2 Col.A and copy its
adjusent to sheet1 Col.B.
I realy need this because it will save me tons of time.
Thank you.