Блог

У меня есть некоторый код, который запускает поиск на втором листе, копирует соответствующие данные строки в указанное местоположение на первом листе. В настоящее время он захватывает первую строку и копирует информацию в лист «Списки работ», мне А) нужно, чтобы он перебирал другие строки с совпадающими именами в столбце 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
  

Не совсем понятно, какие листы вы называете первым и вторым, но из вашего кода я полагаю, что первый — это Destinations, а второй — это Week Listings.

Приведенный ниже код предполагает, что вас интересует только значение в 'Week Listings'!C17 и запись результатов из 'Week Listings'!A20, только поиск столбцов 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 " amp; 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
  

Приведенный выше код будет работать для любой строки, а не для точного текста. Например, «Гамильтон» не найден при поиске «Гамильтон» (пробелы перед и после текста игнорируются).