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

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
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
 
Upvote 0
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
 
Upvote 0
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.
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,212,933
Messages
6,110,759
Members
448,295
Latest member
Uzair Tahir Khan

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
Back
Top