通过工作表循环

我是VBA的初学者（3天前开始）试图build立一个macros。 我希望得到我的代码的帮助，以及了解我出错的部分中的代码是怎么回事。

代码的目标是从每个工作表最后一列的单元格中收集值，并将它们编译到第一个表格（我将在第一次打开工作表时创build）的银行列中。

我的代码是非常原始的，可能包含很多错误。 大多数部分是从源头（甚至是macros观录像机）复制和粘贴的。 我已经设法使其工作，但我希望浓缩它。 这个工作的代码是：

Sub Test() Dim LastCol As Long Dim rng As Range ' Creating a bank sheet Sheets.Add ' Returning to Page 1 Sheets("Page 1").Activate ' Use all cells on the sheet "Page 1" Set rng = Sheets("Page 1").Cells ' Find the last column in "Page 1" and COPY LastCol = Last(2, rng) rng(2, LastCol).Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy ' Paste Selection in Sheet1 Sheets("Sheet1").Activate Sheets("Sheet1").Paste ' Reset cursor to next blank space Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Select ' Repeat for Page 2 Sheets("Page 2").Activate Set rng = Sheets("Page 2").Cells LastCol = Last(2, rng) rng(2, LastCol).Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy Sheets("Sheet1").Activate Sheets("Sheet1").Paste ' Reset cursor to next blank space Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Select ' Repeat for Page 3 Sheets("Page 3").Activate Set rng = Sheets("Page 3").Cells LastCol = Last(2, rng) rng(2, LastCol).Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy Sheets("Sheet1").Activate Sheets("Sheet1").Paste ' Selecting range to sort Set rng = ActiveSheet.Cells LastCell = Last(3, rng) With rng.Parent .Select .Range("A1", LastCell).Select End With ' Sorting ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A177"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Sheet1").Sort .SetRange Range("A2:A176") .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End Sub 

这不适用于具有不同数量的工作表的工作簿。 我试图通过查找工作表的数量并循环来尝试压缩它，但是我无法从在线来源进一步了解。 这是我试图做的：

  For N = 2 To ThisWorkbook.Worksheets.Count ' Use all cells on active sheet ActiveWorkbook.Worksheets(N).Select Set rng = ActiveWorkbook.Cells ' Find the last column in active sheet and COPY LastCol = Last(2, rng) rng(2, LastCol).Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy ' Paste Selection in Sheet1 Sheets("Sheet1").Activate Sheets("Sheet1").Paste ' Reset cursor to next blank space Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Select Next N 

不幸的是，这段代码不起作用。

我怎样才能创build一个循环，以实现我已经能够做我的第一个代码？

我在代码中使用的相关函数如下所示（由Ron De Bruin提供）：

 Function Last(choice As Long, rng As Range) 'Ron de Bruin, 5 May 2008 ' 1 = last row ' 2 = last column ' 3 = last cell Dim lrw As Long Dim lcol As Long Select Case choice Case 1: On Error Resume Next Last = rng.Find(What:="*", _ After:=rng.Cells(1), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 Case 2: On Error Resume Next Last = rng.Find(What:="*", _ After:=rng.Cells(1), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Column On Error GoTo 0 Case 3: On Error Resume Next lrw = rng.Find(What:="*", _ After:=rng.Cells(1), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 On Error Resume Next lcol = rng.Find(What:="*", _ After:=rng.Cells(1), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Column On Error GoTo 0 On Error Resume Next Last = rng.Parent.Cells(lrw, lcol).Address(False, False) If Err.Number > 0 Then Last = rng.Cells(1).Address(False, False) Err.Clear End If On Error GoTo 0 End Select End Function Function LastCol(sh As Worksheet) On Error Resume Next LastCol = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Column On Error GoTo 0 End Function 

Answer 1

这将有助于你开始。 首先，就我所知，这是相同的代码，应该做同样的事情。 它删除所有的select并激活后复制“Page”工作表的最后一行：

 Sub Test() Dim LastCol As Long Dim LastRow As Long Dim NextRowDestination As Long Dim rng As Range Sheets.Add After:=Worksheets(Worksheets.Count) Worksheets(Worksheets.Count).Name = "Sheet1" With Sheets("Page 1") LastCol = Last(2, .Cells) LastRow = Last(1, .Cells(1, LastCol).EntireColumn) Set rng = Range(.Cells(2, LastCol), .Cells(LastRow, LastCol)) rng.Copy Sheets("Sheet1").Cells(2, 1) NextRowDestination = Last(1, Sheets("Sheet1").Cells(1, 1).EntireColumn) + 1 End With With Sheets("Page 2") LastCol = Last(2, .Cells) LastRow = Last(1, .Cells(1, LastCol).EntireColumn) Set rng = Range(.Cells(2, LastCol), .Cells(LastRow, LastCol)) rng.Copy Sheets("Sheet1").Cells(NextRowDestination, 1) NextRowDestination = Last(1, Sheets("Sheet1").Cells(1, 1).EntireColumn) + 1 End With With Sheets("Page 3") LastCol = Last(2, .Cells) LastRow = Last(1, .Cells(1, LastCol).EntireColumn) Set rng = Range(.Cells(2, LastCol), .Cells(LastRow, LastCol)) rng.Copy Sheets("Sheet1").Cells(NextRowDestination, 1) NextRowDestination = Last(1, Sheets("Sheet1").Cells(1, 1).EntireColumn) + 1 End With End Sub 

正如你所看到的，很容易知道每张纸上发生了什么。 另外，你会很快注意到你有很多重复的代码！ 一个循环的完美的地方（你可以得到你的主要问题'如果我有超过3张？'免费回答）！

 Sub Test2() Dim LastCol As Long Dim LastRow As Long Dim counter As Long Dim NextRowDestination As Long Dim rng As Range Dim ws As Worksheet Sheets.Add After:=Worksheets(Worksheets.Count) Worksheets(Worksheets.Count).Name = "Sheet1" NextRowDestination = 2 For counter = 1 To ActiveWorkbook.Worksheets.Count If Left(Worksheets(counter).Name, 4) = "Page" Then Set ws = Worksheets(counter) With ws LastCol = Last(2, .Cells) LastRow = Last(1, .Cells(1, LastCol).EntireColumn) Set rng = Range(.Cells(2, LastCol), .Cells(LastRow, LastCol)) rng.Copy Sheets("Sheet1").Cells(NextRowDestination, 1) NextRowDestination = Last(1, Sheets("Sheet1").Cells(1, 1).EntireColumn) + 1 End With End If Next counter End Sub 

现在请记住，我做了一些假设，没有看到你的数据结构，我很难想象：1）你不想复制任何标题行2）你正在创build的工作表没有一个标题行，数据开始被复制在第2行。3）我没有做任何你的sorting代码，因为我不完全确定你在那里做什么。
4）我没有build立任何检查重复Sheet1或类似的东西。 应该考虑error handling。

但是上面的Test2代码应该让你真正接近你正在做的事情（减去sorting位）。

Answer 2

也许这将有助于：

 Option Explicit Public Sub makeBank() Dim bnk As Worksheet, lrBnk As Long, ur As Range, rngBnk As Range Dim ws As Worksheet, fr As Long, lr As Long, lc As Long, rngThis As Range enableXl False 'disable screen and alerts With Application.ActiveWorkbook For Each ws In .Worksheets 'go through all sheets If ws.Name = "Bank" Then ws.Delete: Exit For 'and remove bnk sheet if exists Next .Worksheets.Add Before:=.Worksheets(1) 'add new sheet before all others Set bnk = .Worksheets(1) 'set a reference to the new sheet bnk.Name = "Bank" 'rename it For Each ws In .Worksheets If ws.Name <> "Bank" Then 'exclude bnk sheet fr = ws.UsedRange.Row 'first used row on current sheet lr = ws.UsedRange.Rows.Count 'last used row on current sheet lc = ws.UsedRange.Columns.Count 'last used col on current sheet Set ur = bnk.UsedRange 'used range on bnk lrBnk = ur.Row + ur.Rows.Count 'last used row on bnk Set rngBnk = bnk.Range(bnk.Cells(lrBnk, 1), bnk.Cells(lrBnk + lr - 1, 1)) Set rngThis = ws.Range(ws.Cells(fr, lc), ws.Cells(lr, lc)) rngBnk.Value2 = rngThis.Value2 'append this last col to bnk's 1st End If Next bnk.Rows(1).EntireRow.Delete 'delete first (extra) row on bnk sortCol bnk.UsedRange.Columns(1) 'sort first column on bnk sheet End With enableXl True 'enable screen and alerts End Sub 

---

其他使用的function：

 Private Sub sortCol(ByVal col As Range) With col.Parent.Sort .SortFields.Clear .SortFields.Add Key:=col, Order:=xlAscending .SetRange col .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .Apply End With End Sub Private Sub enableXl(ByVal opt As Boolean) With Application .ScreenUpdating = opt .DisplayAlerts = opt End With End Sub 

---

主要工作（makeBank）

• 如果存在名为“银行”的工作表，则将其删除
• 创build一个新的“银行”表

• 移动所有表格，除了“银行”和

  • 确定当前表单中的第一个使用的行，最后一个使用的行和最后一个使用的列
  • 确定“Bank”上的第一个空行（加上行复制的偏移量）
  • 复制当前表单上最后一个使用的列，并将其附加到Bank上的第一个空行
  • 移动到下一张表

• 在第一次迭代中，它在Bank上产生一个空行，所以最后它将它移除

• 对Bank上的数据列进行sorting