Search and copy row data VBA

Question

I have some code that runs a search on the second sheet, copy's the matching row data into the specified location the first sheet. Currently It grabs the first row and copies the information into 'Work Listings" sheet, I A) need it to loop for other rows with matching names in the column A and paste the matching data underneath, and if no matching names are found in column A to search column B and copy the matching row data.

Here is what I have so far, which works, I just cant wrack my brains on how to get the loops to work. Any help would be great!!

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

PatricK PatricK · Accepted Answer · 2014-07-04T06:30:17

Not so clear what worksheets you are referring as First and Second, but from your code I believe first is Destinations and second is Week Listings.

Below code assumes you are only interested in value in 'Week Listings'!C17 and write findings from 'Week Listings'!A20, only search columns A, B in Destinations:

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

Search and copy row data VBA

1 Answers