PDA

View Full Version : [SOLVED] Modify code to search multi columns and return data



Barryj
02-22-2015, 10:49 PM
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
02-23-2015, 01:56 AM
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
02-23-2015, 07:04 PM
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
02-24-2015, 05:00 AM
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
02-24-2015, 12:25 PM
Thank you xld that is now working fine, I will mark as solved.