在工作表中循環使用

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 

不幸的是，這段代碼不起作用。

如何創建一個循環來實現我已經能夠處理我的第一個代碼？

我在代碼中使用

相關的功能如下所示（禮貌羅恩德布魯因）：

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代碼應該讓你真正接近你想要做的事情（減去排序位）。

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 

---

其它功能：

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）

• 如果名爲「銀行」工作表存在，則它會刪除它
• 創建新的「銀行」片

• 移動通過所有片材，不同之處「銀行」，和

  • 確定第一次使用行，最後使用行，並在當前片
  • 最後使用的列確定的「銀行」第一個空行（加由複製的行偏移）
  • 副本上當前片上次使用列，並將其追加到第一個空行上銀行
  • 移動到下一紙張

• 在第一次迭代它產生於銀行一個空行，所以在結束它去除它

• 各種數據的列上銀行