Find string in column and paste corresponding row into other sheet

**jolivanes** · 08-27-2013, 10:34 PM

I don't know. Will this do?

Sub With_AutoFilter_A()
    Dim lr As Long
    Application.ScreenUpdating = False
    lr = Sheets("SourceData").Cells(Rows.Count, 1).End(xlUp).Row

    With Sheets("SourceData")
        .AutoFilterMode = False
        .Range("A1:A" & lr).AutoFilter field:=1, Criteria1:="11-11-222"
        With Range("A:A, B:B, D:D").SpecialCells(12)
            .SpecialCells(2).Copy Sheets("Parts").Cells(Rows.Count, "A").End(xlUp)(2)
        End With
        .AutoFilterMode = False
    End With

    Application.ScreenUpdating = True
End Sub

Maybe a slight change in AB33's code will be better.

**briguin** · 08-27-2013, 11:08 PM

Untested...

Option Explicit

Sub CopyRowToAnotherSheet()
Dim strFind As String
Dim NextRow As Long
Dim rngFound As Range
Dim wsSource As Worksheet
Dim wsResult As Worksheet
Dim CL as Variant

'Reset Result sheet
Sheets("Parts").Rows("2:" & Rows.Count).ClearContents
Application.ScreenUpdating = False

'Main Code

Set wsSource = Sheets("SourceData")
Set wsResult = Sheets("Parts")
Set rngFound = wsSource.Range("A1:A15000")

NextRow = wsResult.Range("A" & Rows.Count).End(xlUp).Row
strFind = "11-11-222"
For each CL in RngFound

If instr(CL.Value, "|" & SrtFind) > 0 then

NextRow = NextRow + 1
rngFound.EntireRow.Copy wsResult.Range("A" & NextRow)

end if

Next CL
End Sub

**jolivanes** · 08-28-2013, 01:21 AM

Or maybe like this.

Sub Use_Union()
    Dim lr As Long, c As Range
    Application.ScreenUpdating = False
    lr = Sheets("SourceData").Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("SourceData")
        .AutoFilterMode = False
        .Range("A1:A" & lr).AutoFilter field:=1, Criteria1:="11-11-222"
        For Each c In .Range("A2:A" & lr).SpecialCells(12)
            .Application.Union(c, c.Offset(, 1), c.Offset(, 3)).Copy Sheets("Parts").Cells(Rows.Count, "A").End(xlUp)(2)
        Next c
        .AutoFilterMode = False
    End With
    Application.ScreenUpdating = True
End Sub