VBA: Move group of rows to new sheet based on cell value

[NikoleJay]

Good afternoon!

I hit another snag on a project to help organized documents. I copied a macro from a video that will look at the value of one cell, select the row, and paste it onto another sheet. However, when I modified it, it only selects the third group, and it always pastes it to row 23 on the other sheet even though I specify it to paste below the last row. Please help!

Here is the way the first sheet is set up:

And here is the code I am using:

Sub FindFiled4()
Dim status As String
Dim finalrow As Integer
Dim f As Integer

status = Range("B2").Value
finalrow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For f = 2 To finalrow
If Cells(f, 2) = status Then
Range(Cells(f, 1), Cells(f, 8)).Offset(-1).Resize(3).Copy
Worksheets("Doc Filed").Range("A" & finalrow).PasteSpecial
End If
Next f
End Sub

The end goal if for the code to find every cell that says "Filed," select the row above and below that cell, delete that group of cells so that the cells shift up, and then paste that info on a new sheet after the last row used. However, because I couldn't figure out the copy/paste part, I haven't added a line that will delete the data from the previous sheet.

Any help would be greatly appreciated!

 

[Trebor76]

Hi NikoleJay,

Try this:

Option Explicit
Sub FindFiled5()
    
    Dim status As String
    Dim finalrow As Long
    Dim f As Long
    Dim PasteRow As Long
    Dim wsSource As Worksheet
    Dim wsOutput As Worksheet
    Dim r As Range
    
    Application.ScreenUpdating = False
    
    Set wsSource = ThisWorkbook.Sheets("Sheet1") 'Sheet name containing data. Change to suit.
    Set wsOutput = ThisWorkbook.Sheets("Doc Filed") 'Sheet to have data moved to. Change to suit.
    
    status = wsSource.Range("B2").Value
    finalrow = wsSource.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For f = 3 To finalrow
        If StrConv(wsSource.Cells(f, 2), vbLowerCase) = StrConv(status, vbLowerCase) Then
            If r Is Nothing Then
                Set r = Range(wsSource.Cells(f, 1), wsSource.Cells(f, 8)).Offset(-1).Resize(3)
            Else
                Set r = Union(r, Range(wsSource.Cells(f, 1), wsSource.Cells(f, 8)).Offset(-1).Resize(3))
            End If
            PasteRow = wsOutput.Cells(Rows.Count, "A").End(xlUp).Row + 1
            Range(wsSource.Cells(f, 1), wsSource.Cells(f, 8)).Offset(-1).Resize(3).Copy
            wsOutput.Range("A" & PasteRow).PasteSpecial xlPasteValues
        End If
    Next f
    
    If Not r Is Nothing Then
        r.EntireRow.Delete xlShiftUp
    End If
    
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
    
End Sub

Regards,

Robert

 

[DanteAmor]

Here another macro for you to consider:

Sub Find_Filed()
  Dim lr As Long, i As Long
  Dim sh As Worksheet, rng As Range
  
  Set sh = Sheets("Data")
  lr = sh.Range("A" & Rows.Count).End(3).Row
  Set rng = sh.Range("B" & lr + 1)
  
  For i = 4 To lr
    If sh.Range("B" & i).Value = sh.Range("B2").Value Then Set rng = Union(rng, sh.Range("B" & i - 1).Resize(3))
  Next
  
  rng.EntireRow.Copy Sheets("Doc Filed").Range("A" & Rows.Count).End(3)(2)
  rng.EntireRow.Delete
End Sub

 

[NikoleJay]

I tested both and they work!! Robert, I'm going with yours because it also finds lowercase, and I couldn't figure out how to get the second example to do the same at the moment. I'm still going to save the second example, though. Thank you both for the help!

 

[DanteAmor]

it also finds lowercase,

To find lowercase is a simple change to the code, try the following:

Sub Find_Filed()
  Dim lr As Long, i As Long
  Dim sh As Worksheet, rng As Range
  
  Set sh = Sheets("Data")
  lr = sh.Range("A" & Rows.Count).End(3).Row
  Set rng = sh.Range("B" & lr + 1)
  
  For i = 4 To lr
    If LCase(sh.Range("B" & i).Value) = LCase(sh.Range("B2").Value) Then Set rng = Union(rng, sh.Range("B" & i - 1).Resize(3))
  Next
  
  rng.EntireRow.Copy Sheets("Doc Filed").Range("A" & Rows.Count).End(3)(2)
  rng.EntireRow.Delete
End Sub

 

[NikoleJay]

Oh cool. I was adding it after the range and value. This is my second attempt at making a macro product, so most of it is a guessing game if I can't find examples. Thank you so much for the update!

 

[DanteAmor]

Glad we could help & thanks for the feedback