Move rows when condition met

Adendum

New Member
Joined
Feb 15, 2021
Messages
24
Office Version
  1. 2016
Platform
  1. Windows
Hi Gurus,
I have been lurking for a few days trying to find a solution but nothing quite fits, so I am hopeful some bright spark will share their knowledge with me.

I have a spreadsheet that is gathering data every day (31 sheets - one for each day of the month). At the end of the day I (or a colleague) need to run a macro on the current day's sheet that will search in column D for results that match "With Team A", "With Team B" and "With Team C". There are numerous other results but all the "With..." results are the ones we want to MOVE from the current sheet into a sheet called "The With List".
The "With List" is added to every day. I am not overly concerned about the gaps resulting from the move process.

So as an example from the image below in this day I would like to move rows 3, 6 and 7 to the sheet "The Wish List".

Really looking forward to learn more about this process as I have several other worksheets that could benefit from this treatment.

Many thanks in advance,
Paul.
Capture.PNG
 

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.

lrobbo314

Well-known Member
Joined
Jul 14, 2008
Messages
3,156
Office Version
  1. 365
Platform
  1. Windows
How about this? See commented line of code for changing to your original sheet name.

VBA Code:
Sub MOVEROWS()
Dim ws As Worksheet:    Set ws = Sheets("Data") 'Change to your sheet name
Dim dest As Worksheet:  Set dest = Sheets("The With List")
Dim wList As Object:    Set wList = CreateObject("System.Collections.ArrayList")
Dim nList As Object:    Set nList = CreateObject("System.Collections.arraylist")
Dim r As Range:         Set r = ws.Range("A2:D" & ws.Range("A" & Rows.Count).End(xlUp).Row)
Dim AR() As Variant:    AR = r.Value2
Dim v As Variant

With Application

    For i = 1 To UBound(AR)
        v = .Index(AR, i, 0)
        If AR(i, 4) Like "With*" Then
            wList.Add v
        Else
            nList.Add v
        End If
    Next i

    If nList.Count > 0 Then
        r.ClearContents
        Set r = r.Resize(nList.Count, 4)
        r.Value2 = .Transpose(.Transpose(nList.toArray))
    End If
    
    If wList.Count > 0 Then
        Set r = dest.Range("A" & dest.Rows.Count).End(xlUp).Offset(1).Resize(wList.Count, 4)
        r.Value = .Transpose(.Transpose(wList.toArray))
    End If

End With

End Sub
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
VBA Code:
Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = ActiveSheet
Set sh2 = Sheets("The With List")
With sh1
    .UsedRange.AutoFilter 4, "With*"
    .UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).Copy
    sh2.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValuesAndNumberFormats
    .AutoFilterMode = False
    Application.CutCopyMode = False
End With
End Sub
 

Adendum

New Member
Joined
Feb 15, 2021
Messages
24
Office Version
  1. 2016
Platform
  1. Windows
How about this? See commented line of code for changing to your original sheet name.

VBA Code:
Sub MOVEROWS()
Dim ws As Worksheet:    Set ws = Sheets("Data") 'Change to your sheet name
Dim dest As Worksheet:  Set dest = Sheets("The With List")
Dim wList As Object:    Set wList = CreateObject("System.Collections.ArrayList")
Dim nList As Object:    Set nList = CreateObject("System.Collections.arraylist")
Dim r As Range:         Set r = ws.Range("A2:D" & ws.Range("A" & Rows.Count).End(xlUp).Row)
Dim AR() As Variant:    AR = r.Value2
Dim v As Variant

With Application

    For i = 1 To UBound(AR)
        v = .Index(AR, i, 0)
        If AR(i, 4) Like "With*" Then
            wList.Add v
        Else
            nList.Add v
        End If
    Next i

    If nList.Count > 0 Then
        r.ClearContents
        Set r = r.Resize(nList.Count, 4)
        r.Value2 = .Transpose(.Transpose(nList.toArray))
    End If
   
    If wList.Count > 0 Then
        Set r = dest.Range("A" & dest.Rows.Count).End(xlUp).Offset(1).Resize(wList.Count, 4)
        r.Value = .Transpose(.Transpose(wList.toArray))
    End If

End With

End Sub

Hi,

Firstly many thanks and such a quick response too!
Initial tests are showing that this works like a dream! I'll do a series of test first and get back to you....but it's looking good!

Paul.
 

Adendum

New Member
Joined
Feb 15, 2021
Messages
24
Office Version
  1. 2016
Platform
  1. Windows
VBA Code:
Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = ActiveSheet
Set sh2 = Sheets("The With List")
With sh1
    .UsedRange.AutoFilter 4, "With*"
    .UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).Copy
    sh2.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValuesAndNumberFormats
    .AutoFilterMode = False
    Application.CutCopyMode = False
End With
End Sub

Hi JLGWhiz,
Thanks for the rapid response. Not had a chance to test this yet as Irobbo's seems to do the job perfectly. But I will try yours out and report back as there maybe other users looking for similar needs. I'll get back to you.
Paul
 

Watch MrExcel Video

Forum statistics

Threads
1,130,400
Messages
5,641,924
Members
417,247
Latest member
Chitaah

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