将多个表格中的行复制到一个表格中，然后按列sorting
我正在尝试创build一个VBA，它在E列中search特定条目的七个不同的表单，然后将整个行复制到第8个工作表中，并按A列排列。
我得到了一个点，它search一个电子表格，并将它们复制到另一个在他们位于电子表格完全相同的行
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 我想要search的电子表格包括：周一周二周三周四周五周六周日
我想将它移动到的工作表被称为Completed ，然后我希望它按列Asorting。
有任何想法吗？
这个怎么样：
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
它基本上使用您提供的代码，但是我添加了工作表循环（它将遍历每一天的工作表），并粘贴回“Completed”WS。
看看你是否可以弄清楚我是如何在工作表中循环的 – 我经常使用这种types的东西，所以如果你正在做这么多事情，这将是一件好事。 它还允许您在工作簿中添加另一个工作表（例如“周末”），您只需在arrays中的“Sun”之后添加“Weekend”（周末）即可。 这是你需要添加它的唯一地方。
需要注意的是，我将for each Cell in Range(E:E)从E1改为E列的最后一行，这使得macros运行速度更快。
编辑：正如我在上面的评论中提到的，一般不build议使用Cell作为variables名称。 （ Column ， Row ， Range等）也是如此，因为这些都是VBA（ Cell([row],[column])具体含义，正如你所看到的，我喜欢使用cel或者rng或者iCell ，等等
像这样的东西应该为你工作，根据你所描述的。 它使用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
编辑 ：这是包含代码的示例工作簿。 当我运行代码时，它按预期工作。 你的工作簿数据设置有很大的不同吗？
https://drive.google.com/file/d/0Bz-nM5djZBWYaFV3WnprRC1GMnM/view?usp=sharing
之前发布的答案在其中有一些很棒的东西，但是我认为这会让你确切地知道你以后没有问题，而且速度也很快。 我对数据的布局做了一些假设，但对它们进行了评论。 让我知道事情的后续。
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