Question

我有一些代码在第二张纸上运行搜索，将匹配的行数据复制到第一张纸的指定位置。目前它抓取第一行并将信息复制到“工作清单”表中，IA）需要它在A列中循环匹配名称的其他行并粘贴下面的匹配数据，如果在A列中找不到匹配的名称搜索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

不清楚你所指的工作表是第一和第二，但是从我的代码中我认为首先是目的地，其次是周列表。

以下代码假设您只对＆＃39;周列表＆＃39;！C17 中的价值感兴趣，并写出＆＃39;周列表＆＃39;！A20 <的结果/ kbd>，仅搜索目的地：

中的列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

<小时/> 上面的代码适用于任何字符串，而不是精确的文本。例如。＆＃34;汉密尔顿＆＃34;找不到＆＃34;汉密尔顿＆＃34; （忽略文本前后的空格）。

搜索并复制行数据VBA

1 个答案: