Cut rows, find a specific cell and paste cut rows below that cell row

ihardiks · Mar 19th 2020

Hi Guys,

I'm new to vba and macros and I'm trying to cut certain rows in the for loop and the find a specific value / cell and paste the cut rows below that cell in the same sheet. All this happens with the for loop as the list is dynamic.

'----------16----------select all purple rows

Range("A1").AutoFilter Field:=5, Criteria1:=RGB(204, 192, 218), Operator:=xlFilterCellColor

LR = Range("A" & Rows.Count).End(xlUp).Row

Range("E2:E" & LR).SpecialCells(xlCellTypeVisible).Select

'----------Insert selection contents in an array

Dim arMyArray() As Variant

arMyArray = Selection.Value

'--------------

Range("A1").AutoFilter

For Each elem In arMyArray

a = Right(elem, 12)

Range("A1").AutoFilter Field:=1, Criteria1:=a

Range("A2:F" & LR).SpecialCells(xlCellTypeVisible).Select

Selection.Cut

Range("A1").AutoFilter
Range("A2:F" & LR).Find(What:=elem).Select

Selection.Offset(1).Insert Shift:=xlDown

---- Not sure How I could paste the cut rows below the selected cell.

Thanks for the help!

Mumps · Mar 19th 2020

It would be easier to help and test possible solutions if you could attach a copy of your file. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

ihardiks · Mar 19th 2020

Attached a Sample sheet, the data is mocked for confidentiality purpose. however the code should loop the purple rows and find relevant account numbers in column A, filter those records and paste them below the specific purple row.

Mumps · Mar 19th 2020

Try:

Code

Sub CutRows()
    Application.ScreenUpdating = False
    Dim LR As Long, elem As Variant, arMyArray() As Variant, fnd As Range, count As Long, fVisRow As Long, lVisRow As Long, tRow As Long
    Range("A1").AutoFilter Field:=5, Criteria1:=RGB(204, 192, 218), Operator:=xlFilterCellColor
    tRow = Cells(Rows.count, "A").End(xlUp).Row
    LR = Range("A" & Rows.count).End(xlUp).Row
    arMyArray = Range("E2:E" & LR).SpecialCells(xlCellTypeVisible).Value
    Range("A1").AutoFilter
    For Each elem In arMyArray
        a = Right(elem, 12)
        Range("A1").AutoFilter Field:=1, Criteria1:=a
        fVisRow = Rows("2:" & LR).SpecialCells(xlCellTypeVisible).Row
        lVisRow = Cells(Rows.count, "A").End(xlUp).Row
        count = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.count - 1
        Range("A1").AutoFilter
        Set fnd = Range("E2:E" & LR).Find(elem, LookIn:=xlValues, lookat:=xlPart)
        Cells(fVisRow, 1).Resize(count, 6).Copy
        Cells(fnd.Row + 1, 1).Resize(count, 6).Insert
        If lVisRow < tRow Then
            Rows(fVisRow & ":" & lVisRow).Delete
        Else
            LR = Range("A" & Rows.count).End(xlUp).Row
            Rows(lVisRow + 1 & ":" & LR).Delete
        End If
        LR = Range("A" & Rows.count).End(xlUp).Row
    Next elem
    Application.ScreenUpdating = True
End Sub

Display More

ihardiks · Mar 19th 2020

Thanks a lot, this works for the first 2 purple rows then it crashes. Ideally the purple would could be n in number.

Mumps · Mar 19th 2020

Please attach a file which is more representative of what your actual data can look like.

ihardiks · Mar 19th 2020

Attaching a new sheet, the purple rows could vary on a daily basis. That's why I decided to store them in array and loop through array dynamically

Mumps · Mar 19th 2020

Try:

Code

Sub CutRows()
     Application.ScreenUpdating = False
     Dim LR As Long, elem As Variant, arMyArray() As Variant, fnd As Range, count As Long, fVisRow As Long, lVisRow As Long, tRow As Long
     Range("A1").AutoFilter Field:=5, Criteria1:=RGB(204, 192, 218), Operator:=xlFilterCellColor
     tRow = Cells(Rows.count, "A").End(xlUp).Row
     LR = Range("A" & Rows.count).End(xlUp).Row
     arMyArray = Range("E2:E" & LR).SpecialCells(xlCellTypeVisible).Value
     Range("A1").AutoFilter
     For Each elem In arMyArray
        a = Right(elem, 12)
        Range("A1").AutoFilter Field:=1, Criteria1:=a
        fVisRow = Rows("2:" & LR).SpecialCells(xlCellTypeVisible).Row
        lVisRow = Cells(Rows.count, "A").End(xlUp).Row
        count = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.count - 1
        Range("A1").AutoFilter
        Set fnd = Range("E2:E" & LR).Find(elem, LookIn:=xlValues, lookat:=xlPart)
        Cells(fVisRow, 1).Resize(count, 6).Copy
        Cells(fnd.Row + 1, 1).Resize(count, 6).Insert
        If lVisRow < tRow Then
            Rows(fVisRow & ":" & lVisRow).Delete
        Else
            Rows(lVisRow + 1).Resize(count).Delete
        End If
        LR = Range("A" & Rows.count).End(xlUp).Row
     Next elem
     Application.ScreenUpdating = True
End Sub

Display More

ihardiks · Mar 19th 2020

This worked wonders for me!

Mumps · Mar 20th 2020

Glad it all worked out.

ihardiks · Mar 26th 2020

Hi, while I was testing the above macro code with some other excel sheets I have being getting the "No cell found" error for some of the files and I observed the following pattern. When the purple row starts with the value "ZTF 000000005017" the code works perfectly fine but when the purple rows start with any other record, I get the "No cell found" error. I have attached a sample excel sheet where I receive the error.

I tried debugging this but couldn't get fix it.

Thanks and stay safe!

Mumps · Mar 26th 2020

Try:

Code

Sub CutRows()
     Application.ScreenUpdating = False
     Dim LR As Long, elem As Variant, arMyArray() As Variant, fnd As Range, count As Long, fVisRow As Long, lVisRow As Long, tRow As Long
     LR = Range("A" & Rows.count).End(xlUp).Row
     Range("A1").AutoFilter Field:=5, Criteria1:=RGB(204, 192, 218), Operator:=xlFilterCellColor
     tRow = Cells(Rows.count, "A").End(xlUp).Row
     arMyArray = Range("E2:E" & LR).SpecialCells(xlCellTypeVisible).Value
     Range("A1").AutoFilter
     For Each elem In arMyArray
        a = Right(elem, 12)
        Range("A1").AutoFilter Field:=1, Criteria1:="*" & a
        fVisRow = Rows("2:" & LR).SpecialCells(xlCellTypeVisible).Row
        lVisRow = Cells(Rows.count, "A").End(xlUp).Row
        count = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.count - 1
        Range("A1").AutoFilter
        Set fnd = Range("E2:E" & LR).Find(elem, LookIn:=xlValues, lookat:=xlPart)
        Cells(fVisRow, 1).Resize(count, 6).Copy
        Cells(fnd.Row + 1, 1).Resize(count, 6).Insert
        If lVisRow < tRow Then
            Rows(fVisRow & ":" & lVisRow).Delete
        Else
            Rows(lVisRow + 1).Resize(count).Delete
        End If
        LR = Range("A" & Rows.count).End(xlUp).Row
     Next elem
     Application.ScreenUpdating = True
End Sub

Display More

Cut rows, find a specific cell and paste cut rows below that cell row

Participate now!

Share

Tags