vba - 循环浏览工作表

Question

我是 VBA 初学者(3 天前开始)，试图构建一个宏。我希望获得有关我的代码的帮助，并了解我出错的部分代码中发生了什么。

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

我的代码非常原始，可能包含很多错误。大多数情况下，它是从源(甚至是宏录制器)复制和粘贴的。我已经设法让它发挥作用，但我希望能浓缩它。有效的代码是:

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

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

如何创建一个循环来实现我用第一个代码能够完成的任务？

我在代码中使用的相关函数如下所示(由 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

这希望能帮助您入门。首先，据我所知，这是应该执行相同操作的相同代码。删除所有选择并激活后，它会复制“页面”工作表的最后一行:

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) 您正在创建的工作表没有标题行，数据从第 2 行开始复制。 3)我没有对你的排序代码做任何事情，因为我不完全确定你在那里做了什么。
4)我没有对重复的 Sheet1 或类似的内容进行任何检查。应考虑错误处理。

但是上面的 Test2 代码应该让您非常接近您想要做的事情(减去排序位)。