我是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
答案 0 :(得分：0)
这有望让你入门。首先，就我所知，这是相同的代码应该做同样的事情。在删除所有选择并激活后，它会复制“页面”工作表的最后一行：
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代码应该让你真正接近你想要做的事情（减去排序位）。
答案 1 :(得分：0)
也许这会有所帮助：
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）
移动所有工作表，除了＆＃34; Bank＆＃34;和
在第一次迭代中，它在Bank上生成一个空行，所以最后它会将其删除