find closest match and copy to sheet1
 

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.

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

find closest match and copy to sheet1
 

In excel, you could use a worksheet formula (an array formula) like:

=MATCH(MIN(ABS(sheet1!B1-sheet2!A1:A25)),ABS(sheet1!B1-sheet2!A1:A25),0)
(hit ctrl-shift-enter)

to get the row number of the closest match.

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", .Range("A1").End(xlDown))
End With
With Worksheets("Sheet2")
Set rng1 = .Range("A1", .Range("A1").End(xlDown))
End With

For Each cell In rng.Cells
res = Application.Match(cell, rng1, 0)
If IsNumeric(res) Then
'don't change res!
Else
'change it here
res = Application.Evaluate("match(min(abs(" _
& cell.Address(external:=True) & "-" _
& rng1.Address(external:=True) & ")),abs(" _
& cell.Address(external:=True) & "-" _
& rng1.Address(external:=True) & "),0)")
End If
rng1(res, 2).Resize(1, 2).Copy Destination:=cell.Offset(0, 1)
Next
End Sub



"saman110 via OfficeKB.com" wrote:

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.

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

--

Dave Peterson

find closest match and copy to sheet1
 

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
first = true
for each cell1 in Rng1
if first = true then
closest = rng1
first = false
else
if abs(rng - rng1) < abs(rng - closest) then
closest = rng1)
end if
next cell1
cell.Offset(0, 1) = closest
Next
End Sub


"saman110 via OfficeKB.com" wrote:

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.

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

find closest match and copy to sheet1
 

Joel,

Thank you for responding,

I get syntax error becase this line is in red: closest = rng1)

any idea?
thx.


Joel wrote:
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
first = true
for each cell1 in Rng1
if first = true then
closest = rng1
first = false
else
if abs(rng - rng1) < abs(rng - closest) then
closest = rng1)
end if
next cell1
cell.Offset(0, 1) = closest
Next
End Sub

Hello,

[quoted text clipped - 55 lines]

Thank you.

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

find closest match and copy to sheet1
 

Thank you for responding.

Whenn I run the code I get run type error 13
Type mismatch

when I hit debug it showes this line highlighted:

rng1(res, 2).Resize(1, 2).Copy Destination:=cell.Offset(0, 1)

Thx.

Dave Peterson wrote:
In excel, you could use a worksheet formula (an array formula) like:

=MATCH(MIN(ABS(sheet1!B1-sheet2!A1:A25)),ABS(sheet1!B1-sheet2!A1:A25),0)
(hit ctrl-shift-enter)

to get the row number of the closest match.

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", .Range("A1").End(xlDown))
End With
With Worksheets("Sheet2")
Set rng1 = .Range("A1", .Range("A1").End(xlDown))
End With

For Each cell In rng.Cells
res = Application.Match(cell, rng1, 0)
If IsNumeric(res) Then
'don't change res!
Else
'change it here
res = Application.Evaluate("match(min(abs(" _
& cell.Address(external:=True) & "-" _
& rng1.Address(external:=True) & ")),abs(" _
& cell.Address(external:=True) & "-" _
& rng1.Address(external:=True) & "),0)")
End If
rng1(res, 2).Resize(1, 2).Copy Destination:=cell.Offset(0, 1)
Next
End Sub

Hello,

[quoted text clipped - 58 lines]
--
Message posted via http://www.officekb.com


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

find closest match and copy to sheet1
 

It worked ok with my testing.

How about sharing the data (not the workbook) where the code fails.

"saman110 via OfficeKB.com" wrote:

Thank you for responding.

Whenn I run the code I get run type error 13
Type mismatch

when I hit debug it showes this line highlighted:

rng1(res, 2).Resize(1, 2).Copy Destination:=cell.Offset(0, 1)

Thx.

Dave Peterson wrote:
In excel, you could use a worksheet formula (an array formula) like:

=MATCH(MIN(ABS(sheet1!B1-sheet2!A1:A25)),ABS(sheet1!B1-sheet2!A1:A25),0)
(hit ctrl-shift-enter)

to get the row number of the closest match.

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", .Range("A1").End(xlDown))
End With
With Worksheets("Sheet2")
Set rng1 = .Range("A1", .Range("A1").End(xlDown))
End With

For Each cell In rng.Cells
res = Application.Match(cell, rng1, 0)
If IsNumeric(res) Then
'don't change res!
Else
'change it here
res = Application.Evaluate("match(min(abs(" _
& cell.Address(external:=True) & "-" _
& rng1.Address(external:=True) & ")),abs(" _
& cell.Address(external:=True) & "-" _
& rng1.Address(external:=True) & "),0)")
End If
rng1(res, 2).Resize(1, 2).Copy Destination:=cell.Offset(0, 1)
Next
End Sub

Hello,

[quoted text clipped - 58 lines]
--
Message posted via http://www.officekb.com


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

--

Dave Peterson