Copy rows from multiple Sheets into one, then order by column

Question

I am trying to create a single VBA that searches seven different sheets for a particular entry in Column E and then copy the entire row into a 8th Sheet and placing them in order by column A.

I got the point for it to search for one spreadsheet and copying the items over to the other in the exact same row they are located on the spreadsheet

Sub Test()
    Dim rw As Long, Cell As Range
    For Each Cell In Tues.Range("E:E")
    rw = Cell.Row
     If Cell.Value = "No" Then
      Cell.EntireRow.Copy
       Sheets("Completed").Range("A" & rw).PasteSpecial
     End If
    Next
End Sub

The Spreadsheets I want to search for are: Mon Tues Wed Thurs Fri Sat Sun

The sheet I want to move it to is called Completed, then I want it to sort by Column A.

Any Ideas?

Answer 1

How about this:

Sub loop_through_WS()
Dim rw As Long, i As Long, lastRow As Long, compLastRow&
Dim cel     As Range
Dim mainWS As Worksheet, ws As Worksheet
Dim sheetArray() As Variant

sheetArray() = Array("Mon", "Tues", "Weds", "Thurs", "Fri", "Sat", "Sun")

Set mainWS = Sheets("Completed")

compLastRow = mainWS.Cells(mainWS.Rows.Count, 1).End(xlUp).row

For i = LBound(sheetArray) To UBound(sheetArray)
    With Sheets(sheetArray(i))
        lastRow = .Cells(.Rows.Count, 5).End(xlUp).row
        For Each cel In .Range("E1:E" & lastRow)
            rw = cel.row
            If cel.Value = "No" Then
                cel.EntireRow.copy
                mainWS.Range("A" & compLastRow).pasteSpecial
                compLastRow = mainWS.Cells(mainWS.Rows.Count, 1).End(xlUp).row + 1
            End If
        Next
    End With
Next i

Application.CutCopyMode = False

End Sub

It basically uses the code you gave, but I added the worksheet loop (it'll loop through each of the day worksheets) and paste back onto the "Completed" WS.

See if you can work out how I looped through the worksheets - I use this type of thing often so it'd be good to learn if you are doing much of this. It also allows you to add another sheet (say "Weekend") to your workbook and all you have to do is add "Weekend" after "Sun" in the Array. That's the only place you'll need to add it.

One note is that I changed your for each Cell in Range(E:E) to be from E1 to the last Row in column E - which makes the macro run way faster.

Edit: As mentioned in my comment above, it's generally not recommended to use Cell as a variable name. (Same goes for Column, Row, Range, etc.) because these all mean something specifically to VBA (i.e. Cell([row],[column]). Instead, as you see, I like to use cel or rng or iCell,etc.

Answer 2

The answers posted earlier have some great stuff in them, but I think this will get you exactly what you after with no issues and also with great speed. I made some assumptions on how your data is laid out, but commented them. Let me know how it goes.

Sub PasteNos()

    Dim wsComp As Worksheet
    Dim vSheets() As Variant

    Application.ScreenUpdating = False

    vSheets() = Array("Mon", "Tues", "Weds", "Thurs", "Fri", "Sat", "Sun")

    Set wsComp = Sheets("Completed")

    For i = LBound(vSheets) To UBound(vSheets)

        With Sheets(vSheets(i))

            .AutoFilterMode = False

            .Range(.Range("E1"), .Cells(.Rows.Count, 5).End(xlUp)).AutoFiler 1, "No"
            'assumes row 1 has headers
            .Range(.Range("E2"), .Cells(.Rows.Count, 5).End(xlUp)).SpecialCells(xlCellTypeVisible).EntireRow.Copy

            'pastes into next available row
            With wsComp
                .Range("A" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues 'assumes copy values over
            End With

        End With

    Next i

    'assumes ascending order, headers in row 1, and that data is row-by-row with no blank rows
    wsComp.UsedRange.Sort 1, xlAscending, Header:=xlYes

    Application.ScreenUpdating = True

End Sub

Answer 3

Something like this should work for you based on what you've described. It uses a For Each loop to iterate through the sheets and uses the AutoFilter method to find what it's looking for from column E. The code assumes headers are in row 1 on each sheet. I attempted to comment it for clarity.

Sub tgr()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim wsCompleted As Worksheet
    Dim bHeaders As Boolean

    Set wb = ActiveWorkbook
    Set wsCompleted = wb.Sheets("Completed")
    bHeaders = False

    'Comment out or delete the following line if you do not want to clear current contents of the Completed sheet
    wsCompleted.Range("A2", wsCompleted.Cells(Rows.Count, Columns.Count)).Clear

    'Begin loop through your sheets
    For Each ws In wb.Sheets
        'Only perform operation if sheet is a day of the week
        If InStr(1, " Mon Tue Wed Thu Fri Sat Sun ", " " & Left(ws.Name, 3) & " ", vbTextCompare) > 0 Then

            'If headers haven't been brought in to wsCompleted yet, copy over headers
            If bHeaders = False Then
                ws.Rows(1).EntireRow.Copy wsCompleted.Range("A1")
                bHeaders = True
            End If

            'Filter on column E for the word "No" and copy over all rows
            With ws.Range("E1", ws.Cells(ws.Rows.Count, "E").End(xlUp))
                .AutoFilter 1, "no"
                .Offset(1).Resize(.Rows.Count - 1).EntireRow.Copy wsCompleted.Cells(wsCompleted.Rows.Count, "A").End(xlUp).Offset(1)
                .AutoFilter
            End With

        End If
    Next ws

    'Sort wsCompleted by column A
    wsCompleted.Range("A1").CurrentRegion.Sort wsCompleted.Range("A1"), xlAscending, Header:=xlGuess

End Sub

EDIT: Here is the sample workbook that contains the code. When I run the code, it works as intended. Is your workbook data setup drastically different?

https://drive.google.com/file/d/0Bz-nM5djZBWYaFV3WnprRC1GMnM/view?usp=sharing