將多個表中的行復制到一箇中，然後按列排序

Question

我正在嘗試創建一個VBA，它在E列中搜索特定條目的七個不同工作表，然後將整個行復制到第8個工作表中並按順序放置它們經柱A.

我點爲它尋找一個電子表格，並複製它們所在的電子表格上完全相同的行中的項目轉移到其他

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 

電子表格我想搜索的是： 週一 週二 週三 週四週五 週六 孫

的我想將它移動到被稱爲Completed，然後片，我希望它通過列A.

任何想法進行排序？

Answer 1

像這樣的東西應該爲你工作，根據你所描述的。它使用For Each循環遍歷工作表，並使用AutoFilter方法從E列中查找要查找的內容。該代碼假定頁眉位於每個工作表的第1行。我試圖評論它的清晰。

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：這裏是包含代碼的示例工作簿。當我運行代碼時，它按預期工作。您的工作簿數據設置是否完全不同？

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

Answer 2

如何：

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 

它基本上使用你給的代碼，但我增加了工作循環（它會通過每一天的工作表的循環）並粘貼到回「已完成」WS。

看看你是否可以弄清楚我是如何在工作表中循環的 - 我經常使用這種類型的東西，所以如果你正在做這些事情，這將是一件好事。它還允許您在工作簿中添加另一個工作表（比如說「週末」），並且您只需在陣列中的「Sun」之後添加「週末」。這是您需要添加它的唯一地方。

需要注意的是，我將for each Cell in Range(E:E)從E1更改爲列E中的最後一行，這使得宏運行速度更快。

編輯：正如我在上面的評論中提到的，通常不建議使用Cell作爲變量名稱。 （同去的Column，，Range等），因爲這些都意味着專門VBA東西（即Cell([row],[column])。相反，正如你看到的，我喜歡用cel或rng或iCell等。

Answer 3

答案公佈早些時候他們有一些很棒的東西，但是我認爲這會讓你確切地知道你在做什麼，沒有問題，而且速度也很快，我假設你的數據是如何佈置的，但是評論它們。

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