# Move rows when condition met

##### New Member
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".

Paul.

### 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

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
Else
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
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``````

##### New Member

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
Else
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.

##### New Member
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

Replies
2
Views
200
Replies
10
Views
226
Replies
0
Views
33
Replies
1
Views
49
Replies
1
Views
113

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.

### Which adblocker are you using?

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

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