search并复制行数据VBA

我有一些代码在第二张纸上运行search，将匹配的行数据复制到第一张纸的指定位置。 目前它抓取第一行并将信息复制到“工作列表”表中，IA）需要它循环查找列A中具有匹配名称的其他行，并将匹配的数据粘贴到下面，并且如果在列A中没有find匹配的名称search列B并复制匹配的行数据。

这是我到目前为止，哪些工作，我只是无法绕开我的大脑如何让循环工作。 任何帮助将是伟大的！

Sub Filldata() Dim nxtRow As Integer ActiveSheet.Unprotect With Worksheets("Destinations").Range("A:A") Set c = .Find(Worksheets("Week Listings").Cells(17, 3).Value, LookIn:=xlValues) If c Is Nothing Then Range("A20") = "Not Found" Range("B20") = "Not Found" LCSearch.Hide Select Case MsgBox("ESA code entered is invalid, please check. If it aligns with that shown on the order, take action to have the order corrected.", vbOKOnly + vbDefaultButton1, "Error") Case vbOK End Select Else ActiveSheet.Unprotect mydest = c.Row Range("A20") = Worksheets("Destinations").Cells(mydest, 1) Range("B20") = Worksheets("Destinations").Cells(mydest, 2) Range("C20") = Worksheets("Destinations").Cells(mydest, 3) Range("D20") = Worksheets("Destinations").Cells(mydest, 4) Range("E20") = Worksheets("Destinations").Cells(mydest, 5) Range("F20") = Worksheets("Destinations").Cells(mydest, 6) Range("G20") = Worksheets("Destinations").Cells(mydest, 7) Range("H20") = Worksheets("Destinations").Cells(mydest, 8) LCSearch.Hide ActiveSheet.Unprotect End If End With Worksheets("Week Listings").Range("A20").Select End Sub 

Answer 1

不太清楚你指的是第一和第二个工作表，但是从你的代码我相信第一个是Destinations ，第二个是Week List 。

下面的代码假设你只对“Week List”！C17的价值感兴趣，并写下“Week List”的发现！A20 ，只search目的地中的 A，B列：

 Sub Filldata() On Error Resume Next Dim oWS1 As Worksheet, oWS2 As Worksheet Dim oRngTmp As Range, oRngSearchFor As Range, oRngSearchData As Range, oRngWriteTo As Range Dim i As Long, sTmp As String Set oWS1 = ThisWorkbook.Worksheets("Destinations") Set oWS2 = ThisWorkbook.Worksheets("Week Listings") oWS2.Unprotect ' Search for 'Week Listings'!C17 Set oRngSearchFor = oWS2.Cells(17, 3) oRngSearchFor.Value = UCase(oRngSearchFor.Value) ' Start cell for writing found data Set oRngWriteTo = oWS2.Range("A20") sTmp = "" ' Setup Search Data, first try Column A Set oRngSearchData = oWS1.Columns("A") Set oRngTmp = oRngSearchData.Find(oRngSearchFor.Value, LookIn:=xlValues) If Not oRngTmp Is Nothing Then ' Store first found Address sTmp = oRngTmp.Address Do ' Copy A:H of the matched row to "oRngWriteTo" For i = 1 To 8 oRngWriteTo.Offset(0, i - 1).Value = oWS1.Cells(oRngTmp.Row, i).Value Next ' Move "oRngWriteTo" to next row Set oRngWriteTo = oRngWriteTo.Offset(1, 0) Set oRngTmp = oRngSearchData.FindNext(after:=oRngTmp) Loop While oRngTmp.Address <> sTmp End If ' Setup Search Data, next try Column B Set oRngSearchData = oWS1.Columns("B") Set oRngTmp = oRngSearchData.Find(oRngSearchFor.Value, LookIn:=xlValues) If Not oRngTmp Is Nothing Then ' Store first found Address sTmp = oRngTmp.Address Do ' Copy A:H of the matched row to "oRngWriteTo" For i = 1 To 8 oRngWriteTo.Offset(0, i - 1).Value = oWS1.Cells(oRngTmp.Row, i).Value Next ' Move "oRngWriteTo" to next row Set oRngWriteTo = oRngWriteTo.Offset(1, 0) Set oRngTmp = oRngSearchData.FindNext(after:=oRngTmp) Loop While oRngTmp.Address <> sTmp End If If sTmp = "" Then MsgBox "No results Found for " & oRngSearchFor.Value, vbInformation + vbOKOnly End If oWS2.Protect LCSearch.Hide ' Hide UserForm ' Clean Up Set oRngTmp = Nothing Set oRngSearchData = Nothing Set oRngSearchFor = Nothing Set oRngWriteTo = Nothing Set oWS1 = Nothing Set oWS2 = Nothing End Sub 

---

上面的代码将适用于任何string，而不是确切的文本。 在search“汉密尔顿”时，找不到“汉密尔顿”（文本之前和之后的空格被忽略）。