VBA Find cell value and copy row.

[hmkisner]

I am looking for a simple macro that will find the word "purchasing" in column A and when found cut that row the row above and the two rows below it and paste them to the next sheet. I have found many macro versions that will find the cell and copy the row but im not sure how to change the coding to include above and below rows. This would need to loop through until there are no longer any cells in column A that say purchasing. Thank you in advance for your help!!!!

 

[JoeMo]

You didn't say what you want to do with all the empty rows that result after the cuts. The macro below assumes you want them to remain. The macro has no error handling if "purchasing" should be found in A1 (no row above to cut). It also assumes the "next" sheet is in place and empty when the macro is run.

Sub Purchasing()
Const fWhat As String = "purchasing"
Dim R As Range, fAdr As String, nR As Long, cutRng As Range, Ar As Range
With Sheets("Sheet1")
    Set R = .Range("A:A").Find(fWhat, [A1], xlFormulas, xlPart, , , False)
    If Not R Is Nothing Then
        fAdr = R.Address
        Set cutRng = R.Offset(-1, 0).Resize(4, .UsedRange.Columns.Count)
        Do
            Set R = .Range("A:A").FindNext(R)
            If R Is Nothing Then Exit Do
            If R.Address = fAdr Then Exit Do
            Set cutRng = Union(cutRng, R.Offset(-1, 0).Resize(4, .UsedRange.Columns.Count))
        Loop
    End If
    If Not cutRng Is Nothing Then
        nR = 1
        For Each Ar In cutRng.Areas
            Ar.Cut Destination:=Sheets(.Index + 1).Range("A" & nR)
            nR = Sheets(.Index + 1).Range("A" & Rows.Count).End(xlUp).Row + 1
        Next Ar
    End If
End With
End Sub

 

[Jeffrey Lopez]

Give this one a go, seems to somewhat be working for me...

Sub BottomsUp()


Dim rngCell As Range
Dim lngLstRow As Long


lngLstRow = ActiveSheet.UsedRange.Rows.Count


For i = lngLstRow To 2 Step -1
    Range("A" & i).Select
        If InStr(ActiveCell.Value, "purchasing") > 0 Then
            Range(Rows(ActiveCell.Row - 1), Rows(ActiveCell.Row + 2)).Copy
                Sheets("Sheet1").Select ' Change Sheet Name
                    Range("A65536").End(xlUp).Offset(1, 0).Select
                        Cells(ActiveCell.Row, 1).Insert
                            Sheets("Sheet2").Select ' Change Sheet Name
        End If
Next i


End Sub

 

[Joe4]

There are probably more elegant ways, but this gets the job done and should be easy to modify to suit your needs:

Sub MyCopyMacro()


    Dim shtSearch As Worksheet
    Dim shtPaste As Worksheet
    Dim myLastSearchRow As Long
    Dim myCopyRow As Long
    Dim myPasteRow As Long
    
'******** ENTER THE FOLLOWING VALUES ********
'   Define the name of the sheet you are searching
    Set shtSearch = Sheets("Sheet1")
'   Define the name of the sheet you are pasting
    Set shtPaste = Sheets("Sheet2")
'   Indicate the first row of you are pasting on in your Paste sheet
    myPasteRow = 2
'********************************************
    
    Application.ScreenUpdating = False
    
'   Find last row in column A
    shtSearch.Activate
    myLastSearchRow = shtSearch.Cells(Rows.Count, "A").End(xlUp).Row


'   Loop through all cells in column A
    For myCopyRow = 1 To myLastSearchRow
        If InStr(LCase(shtSearch.Cells(myCopyRow, "A")), "purchasing") > 0 Then
            shtSearch.Rows(myCopyRow - 1 & ":" & myCopyRow + 2).Cut
            shtPaste.Activate
            Cells(myPasteRow, "A").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
            myPasteRow = myPasteRow + 4
            shtSearch.Activate
        End If
    Next myCopyRow
    
    Application.ScreenUpdating = True
    
End Sub

EDIT: I see that a few replies came in while I am was coming up with my code.

 

[hmkisner]

Wow! was not expecting so much help thank you all! I will give them a shot. I would prefer that the blank rows be deleted from the orginal spreadsheet.

 

[Joe4]

If you add this row to my code after the "Next myCopyRow" line, it should delete all the blank rows:

    Range("A1:A" & myLastSearchRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

 

[hmkisner]

Unfortunately, that particular line does not work for this project. Below is what my original worksheet looks like, When I add that line it deletes my addresses. I suppose that I could change to column D and it wouldnt delete any data but it still deletes all my blank rows. The single row in between makes the report easier to read. Most of the purchasing datat is together though so if those areas are not deleted there could be anywhere from 20-200 blank rows before the next set of data. If you cant fix it though i can be happy with this, its exactly what i asked for! Thanks again all!

0000000000	00002	N	BLOOMINGTON		ADDRESS FAILED DPV-NONDELIVERABLE
			RR 3 BOX 145	RR 3 BOX 145
			BLOOMINGTON IL 61705	BLOOMINGTON IL 61705
0000000000	00003	N	COMPANY		ADDRESS FAILED DPV-NONDELIVERABLE
PURCHASING			3110 LATHAM DR	3110 LATHAM DR
			MADISON WI 53713	MADISON WI 53713

<tbody>
</tbody><colgroup><col><col><col><col><col><col></colgroup>

 

[Joe4]

It is always hard to program something when you don't see the data and conditions you are working with!

Try this variation:

Sub MyCopyMacro()


    Dim shtSearch As Worksheet
    Dim shtPaste As Worksheet
    Dim myLastSearchRow As Long
    Dim myCopyRow As Long
    Dim myPasteRow As Long
    
'******** ENTER THE FOLLOWING VALUES ********
'   Define the name of the sheet you are searching
    Set shtSearch = Sheets("Sheet1")
'   Define the name of the sheet you are pasting
    Set shtPaste = Sheets("Sheet2")
'   Indicate the first row of you are pasting on in your Paste sheet
    myPasteRow = 2
'********************************************
    
    Application.ScreenUpdating = False
    
'   Find last row in column A
    shtSearch.Activate
    myLastSearchRow = shtSearch.Cells(Rows.Count, "A").End(xlUp).Row


'   Loop through all cells in column A
    For myCopyRow = 1 To myLastSearchRow
        If InStr(LCase(shtSearch.Cells(myCopyRow, "A")), "purchasing") > 0 Then
            shtSearch.Rows(myCopyRow - 1 & ":" & myCopyRow + 2).Cut
            shtPaste.Activate
            Cells(myPasteRow, "A").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
            myPasteRow = myPasteRow + 4
            shtSearch.Activate
            'Flag rows for deletion
            shtSearch.Range(Cells(myCopyRow - 1, "A"), Cells(myCopyRow + 2, "A")) = "DELETE"
        End If
    Next myCopyRow
    
'   Delete rows with the word "delete" in them using filters
    With shtSearch
        .AutoFilterMode = False
        .Range("A1:A" & myLastSearchRow).AutoFilter
        .Range("A1:A" & myLastSearchRow).AutoFilter Field:=1, Criteria1:="delete"
        Application.DisplayAlerts = False
        .UsedRange.Offset(1, 0).Resize(ActiveSheet.UsedRange.Rows.Count - 1).Rows.Delete
        Application.DisplayAlerts = True
    End With
    ActiveSheet.AutoFilterMode = False
    
    Application.ScreenUpdating = True
    
End Sub

 

[JoeMo]

Wow! was not expecting so much help thank you all! I will give them a shot. I would prefer that the blank rows be deleted from the orginal spreadsheet.

This will delete the blank rows after the cuts are made.

Sub Purchasing()
Const fWhat As String = "purchasing"
Dim R As Range, fAdr As String, nR As Long, cutRng As Range, Ar As Range, i As Long, delAdr As String
With Sheets("Sheet1")
    Set R = .Range("A:A").Find(fWhat, [A1], xlFormulas, xlPart, , , False)
    If Not R Is Nothing Then
        fAdr = R.Address
        Set cutRng = R.Offset(-1, 0).Resize(4, .UsedRange.Columns.Count)
        Do
            Set R = .Range("A:A").FindNext(R)
            If R Is Nothing Then Exit Do
            If R.Address = fAdr Then Exit Do
            Set cutRng = Union(cutRng, R.Offset(-1, 0).Resize(4, .UsedRange.Columns.Count))
        Loop
    End If
    If Not cutRng Is Nothing Then
        delAdr = cutRng.Address
        nR = 1
        For Each Ar In cutRng.Areas
            Ar.Cut Destination:=Sheets(.Index + 1).Range("A" & nR)
            nR = Sheets(.Index + 1).Range("A" & Rows.Count).End(xlUp).Row + 1
        Next Ar
        .Range(delAdr).Delete shift:=xlUp
    End If
End With
End Sub