How to move up/down multiple rows?

Moving rows between worksheets

• QUESTION: I believe you may have looked at something similar in the past but was wondering if you could help with this query. I have a simple workbook with 5 worksheets, one sheet for each member of the team, as an example, my worksheet is called, 'Michael'. Each member of the team has a short summary of projects they are working on that is set out in each row of their worksheet. The last active cell has a filter so that only certain fields can be accepted. This is column 'F'. We have a final sheet called 'Archive'. I'm looking to create an automatic Archive which will move any row where the value in column F equals 'Complete' to the next available row in the Archive worksheet and add a date stamp at the end of the row showing when it was moved. Is this possible? ANSWER: Michael > The last active cell has a filter so that only certain fields can be accepted. I don't know what that means, but if rows are hidden, then that will need to be dealt with in the code - right now I won't worry about it because, as I say, I don't know what that means. Here is some untested pseudo code that shows an approach. I don't have enough details to give you bench tested code. Sub ABC() Dim r As Range, r1 As Range, r2 As Range Dim i As Long, sh1 As Worksheet, cell As Range Dim v As Variant ' list of sheets v = Array("Michael", "John", "Mary", "Fred", "Jim") ' loop through list of sheets For i = LBound(v) To UBound(v) ' clear variable to collect rows to move Set r1 = Nothing ' set a reference to the sheet to be checked Set sh1 = Worksheets(v(i)) ' set reference to the values in column F, start in F2 Set r = sh1.Range("F2", sh1.Cells(sh1.Rows.Count, "F").End(xlUp)) ' loop through the values in column F For Each cell In r ' does this cell in column F contain "complete" If InStr(1, cell, "complete", vbTextCompare) > 0 Then ' if so, add it to the list to be moved If r1 Is Nothing Then Set r1 = cell Else Set r1 = Union(r1, cell) End If End If Next ' are there rows to move If Not r1 Is Nothing Then ' find the next available row in Archive ' by using column F With Worksheets("Archive") Set r2 = .Cells(.Rows.Count, "F").End(xlUp).Offset(1, 0) End With ' reset the bottom reference to column A Set r2 = r2.Offset(0, -5) ' copy the list r1.EntireRow.Copy r2.EntireRow ' delete the source rows that were copied r1.EntireRow.Delete End If Next End Sub As I say, not tested, but represent a concept that could work for you. Test it on a copy of your data. If questions, post a followup posting. ---------- FOLLOW-UP ---------- QUESTION: Sorry i forgot to add, can I also append to the end of the row, the name the worksheet came from, eg. 'Michael'?

• Answer:

  Michael, that's OK. I forgot to put on the time stamp. You said automatic. This macro needs to be run whenever you want to move the data. Trying to react to an entry in column F would be troublesome because people wouldn't necessarily type in complete as the last entry in the row - but as soon as they did, the row would be gone. So I recommend just periodically running a macro like this to clean up the data. Sub ABC() Dim r As Range, r1 As Range, r2 As Range Dim i As Long, sh1 As Worksheet, cell As Range Dim v As Variant, cell1 As Range, rw1 As Long, rw As Long Dim r3 As Range ' list of sheets v = Array("Michael", "John", "Mary", "Fred", "Jim") ' loop through list of sheets For i = LBound(v) To UBound(v) ' clear variable to collect rows to move Set r1 = Nothing ' set a reference to the sheet to be checked Set sh1 = Worksheets(v(i)) ' set reference to the values in column F, start in F2 Set r = sh1.Range("F2", sh1.Cells(sh1.Rows.Count, "F").End(xlUp)) ' loop through the values in column F For Each cell In r ' does this cell in column F contain "complete" If InStr(1, cell, "complete", vbTextCompare) > 0 Then ' if so, add it to the list to be moved If r1 Is Nothing Then Set r1 = cell Else Set r1 = Union(r1, cell) End If End If Next ' are there rows to move If Not r1 Is Nothing Then ' find the next available row in Archive ' by using column F With Worksheets("Archive") Set r2 = .Cells(.Rows.Count, "F").End(xlUp).Offset(1, 0) End With ' reset the bottom reference to column A Set r2 = r2.Offset(0, -5) ' copy the list rw = 0 rw1 = r2.Row For Each cell1 In r1 cell1.EntireRow.Copy r2.Offset(rw, 0).EntireRow With r2.Parent Set r3 = .Cells(rw1, .Cells(rw1, _ .Columns.Count).End(xlToLeft).Column).Offset(0, 1) End With r3.Value = Now r3.NumberFormat = "dd/mm/yyyy hh:mm" r3.EntireColumn.AutoFit r3.Offset(0, 1).Value = cell1.Parent.Name rw = rw + 1 rw1 = rw1 + 1 ' delete the source rows that were copied Next cell1 r1.EntireRow.Delete End If Next End Sub I have tested this with some dummy data that fits at least what you have told me and it worked for me. It assumes all the records will have data in the last column and that they are the same length - otherwise the timestamp and sheet name will not line up.