Excel 将同一列从多个工作表复制到新工作表

我有一本大约20页的工作簿，大约有130行。我想做的是从每个工作表中复制B列并粘贴到新工作表或新工作簿中。这两种方法都可以，我已经尝试了两种方法，我似乎可以从每个工作表中获得B列数据，并将其放在单独的列中。 我尝试了下面的代码，它似乎在各页之间循环，但它只保留了最后一页的B列。 是否有办法修改此代码，将每个工作表中的每个B列粘贴到新工作表的新列中？我在这里尝试了文章中的其他代码片段，但似乎没有一个能够完成最后的任务

Sub CopyColumns()

Dim Source As Worksheet
Dim Destination As Worksheet
Dim Last As Long

Application.ScreenUpdating = False

For Each Source In ThisWorkbook.Worksheets
    If Source.Name = "Master" Then
        MsgBox "Master sheet already exist"
        Exit Sub
    End If
Next

Set Destination = Worksheets.Add(after:=Worksheets("summary"))
Destination.Name = "Master"

For Each Source In ThisWorkbook.Worksheets    
    If Source.Name <> "Master" And Source.Name <> "summary" Then        
        Last = Destination.Range("A1").SpecialCells(xlCellTypeLastCell).Column        
        If Last = 1 Then
            Source.Range("B4:B129").Copy Destination.Columns(Last)
        Else
            Source.Range("B4:B129").Copy Destination.Columns(Last + 1)
        End If
    End If
Next Source

任何帮助都将不胜感激

未经测试：

Sub CopyColumns()

    Dim Source As Worksheet
    Dim Destination As Worksheet
    Dim rngDest As Range

    Application.ScreenUpdating = False

    For Each Source In ThisWorkbook.Worksheets
        If Source.Name = "Master" Then
            MsgBox "Master sheet already exist"
            Exit Sub
        End If
    Next

    Set Destination = Worksheets.Add(after:=Worksheets("summary"))
    Destination.Name = "Master"
    Set rngDest = Destination.Range("A1") '<< for example: first paste location

    For Each Source In ThisWorkbook.Worksheets    
        If Source.Name <> "Master" And Source.Name <> "summary" Then

            Source.Range("B4:B129").Copy rngDest        
            Set rngDest = rngDest.Offset(0, 1)  '<< next column over        

        End If
    Next Source

End Sub

子复制列（）
将源设置为工作表
将目标设置为工作表
Dim rngDest As范围
Application.ScreenUpdating=False
用于此工作簿中的每个源。工作表
如果Source.Name=“Master”，则
MsgBox“主工作表已存在”
出口接头
如果结束
下一个
设置目的地=工作表。添加（之后：=工作表（“摘要”））
Destination.Name=“Master”
设置rngDest=Destination.Range（“A1”）”未测试：

Sub CopyColumns()

    Dim Source As Worksheet
    Dim Destination As Worksheet
    Dim rngDest As Range

    Application.ScreenUpdating = False

    For Each Source In ThisWorkbook.Worksheets
        If Source.Name = "Master" Then
            MsgBox "Master sheet already exist"
            Exit Sub
        End If
    Next

    Set Destination = Worksheets.Add(after:=Worksheets("summary"))
    Destination.Name = "Master"
    Set rngDest = Destination.Range("A1") '<< for example: first paste location

    For Each Source In ThisWorkbook.Worksheets    
        If Source.Name <> "Master" And Source.Name <> "summary" Then

            Source.Range("B4:B129").Copy rngDest        
            Set rngDest = rngDest.Offset(0, 1)  '<< next column over        

        End If
    Next Source

End Sub

子复制列（）
将源设置为工作表
将目标设置为工作表
Dim rngDest As范围
Application.ScreenUpdating=False
用于此工作簿中的每个源。工作表
如果Source.Name=“Master”，则
MsgBox“主工作表已存在”
出口接头
如果结束
下一个
设置目的地=工作表。添加（之后：=工作表（“摘要”））
Destination.Name=“Master”
将rngDest=Destination.Range（“A1”）同一列从多个工作表设置为新工作表

将完整的代码复制到标准模块中（例如，
Module1
）
仔细调整
子部分的常数部分中的值

仅运行
子项
。
子函数调用
函数

如果需要将目标工作表置于另一工作表之前，
将
wb.Worksheets.Add、wb.Worksheets（AfterSheetNameOrIndex）
更改为

wb.Worksheets.Add wb.Worksheets（AfterSheetNameOrIndex）

代码

选项显式
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'目的：复制每列的指定列的值（可能的'
“例外情况）工作簿中的工作表到新创建的”
“同一工作簿中的工作表。”
'备注：如果要创建的工作表已经存在，它将被删除'
"删除。然后计算结果，直到现在'
'将新建工作表以“接收数据”。'
'异常数组可以为空（“”），也可以包含一个'
'工作表名称或以逗号分隔的工作表名称列表。'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
子复制列（）
关于错误转到cleanError
Const Proc As String=“CopyColumns”
常量srcFirstRow的长度=4
Const srcCol As Variant=2
Const tgtName As String=“Master”
常量tgtFirstCell为String=“A1”
Const AfterSheetNameOrIndex As Variant=“Summary”
作为变量的Dim异常
异常=数组（“摘要”）
'定义工作簿。
将wb设置为工作簿：设置wb=ThisWorkbook
'删除可能存在的目标工作表。
出错时继续下一步
Application.DisplayAlerts=False
工作表（tgtName）。删除
Application.DisplayAlerts=True
关于错误转到cleanError
'将每个源工作表中的值写入数组的源数组。
作为变量的Dim源：ReDim源（1到wb.Worksheets.Count）
将ws标注为工作表，r标注为长，c标注为长
对于此工作簿中的每个ws。工作表
如果IsError（Application.Match（ws.Name，Exceptions，0））那么
c=c+1
Sources（c）=getColumnValues（ws、srcCol、srcFirstRow）
如果不是空的（来源（c）），那么
如果UBound（震源（c））>r，则r=UBound（震源（c））
调试。打印r、c、UBound（源代码（c）），“非空”
其他的
调试。打印r，c，“空”
如果结束
如果结束
下一个ws
ReDim保留源（1到c）
'将值从数组的源数组写入目标数组。
变光目标：变光目标（1至右，1至c）
我和j一样长，我也一样长
对于j=1到c
如果不是空的（来源（j）），那么
对于i=1至UBound（震源（j））
目标（i，j）=源（j）（i，1）
接下来我
如果结束
下一个j
'将值从目标数组写入目标工作表。
wb.Worksheets.Add，wb.Worksheets（表后名称索引）
设置ws=wb.ActiveSheet
ws.Name=tgtName
ws.Range（tgtFirstCell）.Resize（r，c）=目标
'通知用户。
MsgBox“已复制数据”，vbInformation，“成功”
出口接头
清除错误：
MsgBox“在'&Proc&'.&vbCr'中发生意外错误”_
&“运行时错误”“&Err.Number&”“：”&vbCr&Err.Description_
vbCritical、Proc和“错误”
错误转到0
端接头
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'目的：从开始写入非空一栏范围的值'
'从指定的行到基于一列的二维数组。'
'返回：基于一列的二维数组。'
'备注：如果列为空或其最后一个非空行位于上方'
'指定的行或如果发生错误，函数将'
'返回一个空变量。因此函数的结果
“可以使用测试”