Move rows when condition met

[Adendum]

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.

 

[lrobbo314]

How about this? See commented line of code for changing to your original sheet name.

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]

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]

How about this? See commented line of code for changing to your original sheet name.

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]

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