Modify code to search multi columns and return data

[Barryj]

I am using the below code to search column B for a value that appears in H1 on sheet1, it then copys the entire row to sheet3, I want this macro to be able to search multipule columns and copy four columns of data for each range.

Private Sub commandbutton1_click()
With Excel.ThisWorkbook.Sheets("Sheet1")
    Dim cell
    For Each cell In .Range(.Cells(2, 2), Cells(.Rows.Count, 1).End(Excel.xlUp))
        If UCase(cell(1, 1)) = Sheets("Sheet1").Range("H1") Then
            With Excel.ThisWorkbook.Sheets("Sheet2")
                Cells(1, 4).Copy .Cells(.Rows.Count, 1).End(Excel.xlUp)(2, 1)
            End With
        End If
        If UCase(cell(1, 1)) = .Range("H1") Then
            With Excel.ThisWorkbook.Sheets("Sheet3")
            Cells(1, 4).Copy .Cells(.Rows.Count, 1).End(Excel.xlUp)(2, 1)
            End With
        End If
    Next
End With
End Sub

What I want to do is the following:
Search column B for value in H1 copy data range A to D
Search Column G for value in H1 copy data range F to I
Search Column L for value in H1 copy data range K to N
Search Column Q for value in H1 copy data range P to S

I have attached a workbook showing the input and output data.

Sheet 1 has the input data and sheet 3 the desired output results

Thanks for any assistance or guideance

[Bob Phillips]

Sub Button1_Click()
Dim ws As Worksheet
    
    Set ws = ThisWorkbook.Sheets("Sheet3")
    
    With ThisWorkbook
    
        Call CopyValues(.Sheets("Sheet1"), ws, 1)
        Call CopyValues(.Sheets("Sheet1"), ws, 6)
        Call CopyValues(.Sheets("Sheet1"), ws, 11)
        Call CopyValues(.Sheets("Sheet1"), ws, 16)
    End With
End Sub

Private Sub CopyValues(this As Worksheet, target As Worksheet, col As Long)
Dim cell As Range
Dim firstaddress As String
Dim lastrow As Long
    
    With this
    
        lastrow = target.Cells(target.Rows.Count, col).End(xlUp).Row + 1
        Set cell = .Columns(col + 1).Find(.Range("H1").Value)
        If Not cell Is Nothing Then firstaddress = cell.Address
        Do
        
            cell.Resize(, 4).Copy target.Cells(lastrow, col)
            Set cell = .Columns(col + 1).FindNext(cell)
            lastrow = lastrow + 1
        Loop Until cell.Address = firstaddress
    End With
End Sub

[Barryj]

Thanks for the assistance xld, just having 2 problems, firstly the adjacent dates are not transfering over with the other data ans when I change the value in H1 it comes up with a 1004 runtime error, I have played around with the code but it still has the 2 problems I have mentioned.

Thanks for your help.

[Bob Phillips]

Try this amendment

Sub Button1_Click()
Dim ws As Worksheet
    
    Set ws = ThisWorkbook.Sheets("Sheet3")
    
    With ThisWorkbook
    
        Call CopyValues(.Sheets("Sheet1"), ws, 1)
        Call CopyValues(.Sheets("Sheet1"), ws, 6)
        Call CopyValues(.Sheets("Sheet1"), ws, 11)
        Call CopyValues(.Sheets("Sheet1"), ws, 16)
    End With
End Sub

Private Sub CopyValues(this As Worksheet, target As Worksheet, col As Long)
Dim cell As Range
Dim firstaddress As String
Dim lastrow As Long
    
    With this
    
        lastrow = target.Cells(target.Rows.Count, col).End(xlUp).Row + 1
        Set cell = .Columns(col + 1).Find(.Range("H1").Value)
        If Not cell Is Nothing Then
        
            firstaddress = cell.Address
            Do
            
                cell.Offset(0, -1).Resize(, 4).Copy target.Cells(lastrow, col)
                Set cell = .Columns(col + 1).FindNext(cell)
                lastrow = lastrow + 1
            Loop Until cell.Address = firstaddress
        End If
    End With
End Sub

[Barryj]

Thank you xld that is now working fine, I will mark as solved.