View Single Post
  #4   Report Post  
Posted to microsoft.public.excel.misc
Dave Peterson Dave Peterson is offline
external usenet poster
 
Posts: 35,218
Default 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