同一列从多个工作表到新工作表
- 将完整代码复制到标准模块中（例如
Module1）。
- 仔细调整
Sub的constants部分中的值。
- 只运行
Sub。 Function 由 Sub 调用。
- 如果您需要将
Target Worksheet 放在另一个工作表之前，
将 wb.Worksheets.Add , wb.Worksheets(AfterSheetNameOrIndex) 更改为
wb.Worksheets.Add wb.Worksheets(AfterSheetNameOrIndex)。
守则
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Copies values of a specified column of each (with possible '
' exceptions) worksheet in a workbook to a newly created '
' worksheet in the same workbook. '
' Remarks: If the worksheet to be created already exists, it will be '
' deleted. Then the result will be calculated and only now '
' the worksheet will be newly created to "recieve the data". '
' The Exceptions Array can be empty (""), or can contain one '
' worksheet name or a comma-separated list of worksheet names. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub copyColumns()
On Error GoTo cleanError
Const Proc As String = "CopyColumns"
Const srcFirstRow As Long = 4
Const srcCol As Variant = 2
Const tgtName As String = "Master"
Const tgtFirstCell As String = "A1"
Const AfterSheetNameOrIndex As Variant = "Summary"
Dim Exceptions As Variant
Exceptions = Array("Summary")
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook
' Delete possibly existing Target Worksheet.
On Error Resume Next
Application.DisplayAlerts = False
wb.Worksheets(tgtName).Delete
Application.DisplayAlerts = True
On Error GoTo cleanError
' Write values from each Source Worksheet to Sources Array of Arrays.
Dim Sources As Variant: ReDim Sources(1 To wb.Worksheets.Count)
Dim ws As Worksheet, r As Long, c As Long
For Each ws In ThisWorkbook.Worksheets
If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
c = c + 1
Sources(c) = getColumnValues(ws, srcCol, srcFirstRow)
If Not IsEmpty(Sources(c)) Then
If UBound(Sources(c)) > r Then r = UBound(Sources(c))
Debug.Print r, c, UBound(Sources(c)), "Not Empty"
Else
Debug.Print r, c, "Empty"
End If
End If
Next ws
ReDim Preserve Sources(1 To c)
' Write values from Source Array of Arrays to Target Array.
Dim Target As Variant: ReDim Target(1 To r, 1 To c)
Dim j As Long, i As Long
For j = 1 To c
If Not IsEmpty(Sources(j)) Then
For i = 1 To UBound(Sources(j))
Target(i, j) = Sources(j)(i, 1)
Next i
End If
Next j
' Write values from Target Array to Target Worksheet.
wb.Worksheets.Add , wb.Worksheets(AfterSheetNameOrIndex)
Set ws = wb.ActiveSheet
ws.Name = tgtName
ws.Range(tgtFirstCell).Resize(r, c) = Target
' Inform user.
MsgBox "Data copied.", vbInformation, "Success"
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description, _
vbCritical, Proc & " Error"
On Error GoTo 0
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Writes the values of a non-empty one-column range starting '
' from a specified row, to a 2D one-based one-column array. '
' Returns: A 2D one-based one-column array. '
' Remarks: If the column is empty or its last non-empty row is above '
' the specified row or if an error occurs the function will '
' return an empty variant. Therefore the function's result '
' can be tested with "IsEmpty". '
' If showMessages is set to true, a message box will be '
' displayed; so use it with caution. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getColumnValues(Sheet As Worksheet, _
Optional ByVal AnyColumn As Variant = 1, _
Optional ByVal FirstRow As Long = 1, _
Optional ByVal showMessages As Boolean = False) _
As Variant
' Prepare.
Const Proc As String = "getColumnValues"
If showMessages Then
Dim msg As String
End If
On Error GoTo cleanError
' Define Column Range.
Dim rng As Range
Set rng = Sheet.Columns(AnyColumn).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then GoTo EmptyColumnIssue
If rng.Row < FirstRow Then GoTo FirstRowIssue
Set rng = Sheet.Range(Sheet.Cells(FirstRow, AnyColumn), rng)
' Write values from Column Range to Column Array.
Dim Result As Variant
If rng.Rows.Count = 1 Then
ReDim Result(1 To 1, 1 To 1): Result(1, 1) = rng.Value
Else
Result = rng.Value
End If
getColumnValues = Result
' Possibly inform user.
GoSub writeSuccess
Exit Function
writeSuccess:
If showMessages Then
If UBound(Result) > 1 Then msg = "s"
msg = "Range '" & rng.Address(0, 0) & "' " _
& "was successfully written to the 2D one-based " _
& "one-column array containing '" & UBound(Result) & "' " _
& "element" & msg & " (row" & msg & ")."
GoSub msgWSB
MsgBox msg, vbInformation, Proc & ": Success"
End If
Return
EmptyColumnIssue:
If showMessages Then
msg = "Column '" & AnyColumn & "' is empty."
GoSub msgWSB
MsgBox msg, vbExclamation, Proc & ": Empty Column Issue"
End If
Exit Function
FirstRowIssue:
If showMessages Then
msg = "The last non-empty row '" & rng.Row & "' " _
& "is smaller than the specified first row '" & FirstRow & "'."
GoSub msgWSB
MsgBox msg, vbExclamation, Proc & ": First Row Issue"
End If
Exit Function
msgWSB:
msg = msg & vbCr & vbCr & "Worksheet: '" & Sheet.Name & "'" & vbCr _
& "Workbook : '" & Sheet.Parent.Name & "'"
Return
cleanError:
If showMessages Then
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
End If
On Error GoTo 0
End Function