CODEWITHSUNDEEP
vbaexcel
John Doe
John Doe

Reputation: 31

Copy all rows with search criteria from cell in range

I search vba script, for searching value in cells range, and copy all rows that contain looking value to another sheet, i.e.:

SEARCH TABLE:

column_1 column_2 column_3 column_4 column_5
  1      value_a  value_b  value_c  value_d
  2      value_e  value_a  value_f  value_g
  3      value_h  value_i  value_j  value_k
  4      value_l  value_a  value_m  value_n

In cell "Z1" is looking value (for example value_a) and I wanna search it in above table , than copy (to new sheet) all rows that contain that value i.e:

NEW SHEET:

  1      value_a  value_b  value_c  value_d
  2      value_e  value_a  value_f  value_g
  4      value_l  value_a  value_m  value_n

Upvotes: 0

Views: 85

Answers (2)

Error 1004
Error 1004

Reputation: 8220

Try:

Public Sub test()

    Dim i As Long, LastRow1 As Long, LastRow2 As Long
    Dim rng As Range
    Dim SearchValue As String
    
    SearchValue = "value_a"
    
    'Refer to the source worksheet
    With ThisWorkbook.Worksheets("Sheet1")
        'Get last row of column A of sheet 1
        LastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
        'Loop rows starting from row 1 until last row
        For i = 1 To LastRow1
            'Create the range. Range start from column B and ends at column E
            With .Range("B" & i & ":E" & i)
                'Search to find "value_a"
                Set rng = .Find(SearchValue, LookIn:=xlValues, LookAt:=xlWhole)
                'Check if value exist in the row
                If Not rng Is Nothing Then
                
                    With ThisWorkbook.Worksheets("Sheet2")
                        'Get last row of column A of sheet 2
                        LastRow2 = .Cells(.Rows.Count, "A").End(xlUp).Row
                        'Copy past values
                        ThisWorkbook.Worksheets("Sheet1").Range("A" & i & ":E" & i).Copy .Range("A" & LastRow2 + 1 & ":E" & LastRow2 + 1)
                    End With
                End If
            End With
        Next i
    End With
End Sub

Upvotes: 0

Kᴀτᴢ
Kᴀτᴢ

Reputation: 2176

Try this:

Sub copyrow()
col = 1
actrow = 2 'start in row 2

While Not IsEmpty(Cells(actrow, col)) 'check A2:A last row

Do While Not IsEmpty(Cells(actrow, col))
If Cells(actrow, col) = Cells(1, 24) Then 'check actual cell with Z1
Range("A" & actrow, "D" & actrow).Select 'select range to copy
Selection.copy
Worksheets("new").Activate 'new = sheet to copy the data
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
lastrow = lastrow + 1
Cells(lastrow, 1).Select
ActiveSheet.Paste 'copy in next free row
Worksheets("Tabelle1").Activate 'table1 = your sheet with data
col = col + 1
Exit Do

Else
col = col + 1
End If
Loop

actrow = actrow + 1
col = 1
Wend

End Sub

Upvotes: 1

Related Questions