复制数据使用Vba，Matchfunction
我是一个新的编码器。 只是在VBBA初学者，并希望有一些帮助来解决这个问题。 我知道我可以使用正常的Excel公式，但这是学习。 这是我的代码到目前为止：
Sub matchpart() Dim ocell As Range Dim swb As Workbook Dim sws As Worksheet, dws As Worksheet Dim stext As String Dim iRow As Long Dim nxtRow As Long Set swb = ActiveWorkbook Set sws = swb.Sheets("sheet1") Set dws = swb.Sheets("sheet2") For Each ocell In dws.Range("FILE_NAMES") stext = Left(ocell.Value, 12) On Error Resume Next iRow = Application.WorksheetFunction.Match(stext, sws.Range("ID_NUMBER"), 0) On Error GoTo 0 If iRow > 0 Then Application.Index (Range("ID_PARENT").Copy) Else ocell.Offset(0, 1) = "" End If Next MsgBox ("Done") End Sub 我的任务是匹配表2（ID_NUMBER）中的1列与1列表1（FILE_NAMES）。 之后，复制表单1（已匹配）的下一列中的相应值，并将其粘贴到表单2中的下一列中。
这里是我的数据作为例如sheet1：
ID_PARENT ID_NUMBER pan 3 same 2 kappa 1 lame 5 dame 5 sheet 2: FILE_NAMES BPM_LIST 1 5 3 2 4 5
因此想要使用我的代码匹配并复制到BPM_LIST。
不要使用Application.WorksheetFunction.Match(...) ; 使用Application.Match(...)并将返回值传回给变体。 这将允许您检查IsError(...) 。
此外，（就像在工作表上使用MATCH一样），您不能使用text-that-look-like-a-number来定位数字; 例如1 <> "1" 。 我不知道你的数据实际上是什么样的（真正的数字或文本，看起来像数字），但你可能不得不使用Int(stext)而不是在匹配中的stext 。
dim iRow as variant For Each ocell In dws.Range("FILE_NAMES") stext = Left(ocell.Value, 12) iRow = Application.Match(stext, sws.Range("ID_NUMBER"), 0) If IsError(iRow) Then ocell.Offset(0, 1) = vbnullstring Else ocell.Offset(0, 1) = Range("ID_PARENT").Cells(lRow, 1).Value End If Next ocell
你想要学习和学习的代码。 这里是。 我并没有太在意它是否也做了你想要的，因为我认为你可以调整我的代码的方向，你希望它弯曲。 玩的开心！
Sub matchpart() ' 10 Apr 2017 Dim Wb As Workbook Dim WsSrc As Worksheet ' Identify the sheet as Source Dim WsTgt As Worksheet ' Identify the sheet as Target Dim sText As String Dim R As Long, lastRow As Long ' last row in WsTgt Dim iRow As Long ' why do you call "Found row" iRow? Set Wb = ActiveWorkbook ' actually, this is the default With Wb ' declaring it just reminds you of the fact Set WsSrc = .Sheets("IDs") Set WsTgt = .Sheets("File Names") ' I used my own names for testing End With With WsTgt lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' most programmers prefer to call the columns by their numbers ' instead of their names (like "A") as I have done here. ' VBA must convert the names to numbers. ' Therefore using numbers to begin with is faster. ' You can change all names to numbers in this code ' Just replace "A" with 1, "B" with 2 etc. For R = 2 To lastRow ' omit row 1 (captions) sText = .Cells(R, "A").Value ' can't use partial with MATCH function On Error Resume Next iRow = WorksheetFunction.Match(sText, WsSrc.Columns("B"), 0) If Err.Number = 0 Then .Cells(R, "B").Value = WsSrc.Cells(iRow, "A").Value End If Err.Clear Next R End With MsgBox ("Done") End Sub
我的代码从你的意图转移的一点是，你想要一个“部分匹配”。 这是使用MATCH工作表函数无法实现的。 你需要使用VBA的Find。 但是，这可能是另一天更好的另一个教训，哈哈：
嗨，抱歉你没有时间。 我发现我的解决scheme，我的问题。 这只是使用索引函数，因为我已经得到了匹配的行号，即iRow。
Sub matchpart() Dim ocell As Range Dim ocells As Range Dim swb As Workbook Dim sws As Worksheet, dws As Worksheet Dim stext As String Dim iRow As Long Dim nxtRow As Long Set swb = ActiveWorkbook Set sws = swb.Sheets("sheet1") Set dws = swb.Sheets("sheet2") For Each ocell In dws.Range("FILE_NAMES") stext = Left(ocell.Value, 12) On Error Resume Next iRow = Application.WorksheetFunction.Match(stext, sws.Range("ID_NUMBER"), 0) On Error GoTo 0 If iRow > 0 Then ocell.Offset(0, 1) = WorksheetFunction.Index(sws.Range("ID_PARENT"), iRow, 0) Else ocell.Offset(0, 1) = "" End If Next MsgBox ("Done") End Sub
感谢您的帮助:)