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

NikoleJay

New Member
Joined
May 9, 2020
Messages
14
Office Version
  1. 365
Platform
  1. Windows
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:
Sheet Example.png



And here is the code I am using:
VBA Code:
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!
 

Some videos you may like

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,735
Hi NikoleJay,

Try this:

VBA Code:
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

Well-known Member
Joined
Dec 3, 2018
Messages
12,619
Office Version
  1. 2007
Platform
  1. Windows
Here another macro for you to consider:

VBA Code:
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

New Member
Joined
May 9, 2020
Messages
14
Office Version
  1. 365
Platform
  1. Windows
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

Well-known Member
Joined
Dec 3, 2018
Messages
12,619
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

it also finds lowercase,

To find lowercase is a simple change to the code, try the following:
VBA Code:
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

New Member
Joined
May 9, 2020
Messages
14
Office Version
  1. 365
Platform
  1. Windows
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

Well-known Member
Joined
Dec 3, 2018
Messages
12,619
Office Version
  1. 2007
Platform
  1. Windows
Glad we could help & thanks for the feedback
 

Watch MrExcel Video

Forum statistics

Threads
1,127,870
Messages
5,627,359
Members
416,245
Latest member
Xterminat

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top