批量将300个工作簿G列数据复制到新表相邻列的VBA代码问题

问题根源 #

你的原代码未实现目标列的动态递增逻辑，每次复制操作都指向同一列，导致新数据持续覆盖旧数据，无法按工作簿顺序依次写入A、B、C...列。

修改后的可运行VBA代码 #

Sub CopyWorkbookGColumns()
    Dim MyFile As String
    Dim Filepath As String
    Dim targetSheet As Worksheet
    Dim sourceWB As Workbook
    Dim sourceWS As Worksheet
    Dim lastRow As Long
    Dim targetCol As Integer ' 记录当前要写入的目标列
    
    ' 指定数据写入的目标工作表（这里用当前工作簿的Sheet1）
    Set targetSheet = ThisWorkbook.Sheets("Sheet1")
    targetCol = 1 ' 从A列开始写入
    
    ' 填写你的文件夹路径，务必添加末尾的反斜杠
    Filepath = "C:\你的文件夹路径\"
    
    ' 获取文件夹中的Excel文件，可根据实际格式调整后缀（如*.xls、*.xlsm）
    MyFile = Dir(Filepath & "*.xlsx")
    
    Do While Len(MyFile) > 0
        ' 跳过当前运行代码的工作簿
        If MyFile = ThisWorkbook.Name Then
            MyFile = Dir
            Continue Do
        End If
        
        ' 打开源工作簿
        Set sourceWB = Workbooks.Open(Filepath & MyFile)
        ' 获取与文件名同名的源工作表（去掉.xlsx后缀）
        Set sourceWS = sourceWB.Sheets(Left(MyFile, Len(MyFile) - 5))
        ' 若源文件是.xls格式，将上面的-5改为-4
        
        ' 可靠获取G列最后一行（避免空行干扰）
        lastRow = sourceWS.Cells(sourceWS.Rows.Count, "G").End(xlUp).Row
        
        ' 复制G列数据到目标工作表的当前列
        sourceWS.Range("G1:G" & lastRow).Copy targetSheet.Cells(1, targetCol)
        
        ' 关闭源工作簿，无需保存（若源文件未做修改）
        sourceWB.Close SaveChanges:=False
        
        ' 目标列递增，准备写入下一个工作簿的数据
        targetCol = targetCol + 1
        
        ' 获取下一个文件
        MyFile = Dir
    Loop
End Sub

核心修改说明 #

• 目标列动态递增：新增targetCol变量，初始值为1（对应A列），每处理完一个工作簿就自动加1，确保数据依次写入下一列。
• 精准匹配源工作表：通过截取文件名去掉后缀的方式，直接获取与工作簿同名的工作表，完全匹配你的需求。
• 优化最后一行获取：使用Rows.Count + End(xlUp)的方式定位G列最后一行，避免CurrentRegion因空行导致的范围错误。
• 灵活过滤当前工作簿：通过ThisWorkbook.Name判断跳过运行代码的文件，无需硬编码文件名，适配性更强。

注意事项 #

• 文件夹路径必须以反斜杠结尾，否则会出现路径拼接错误。
• 根据源文件的实际格式（.xlsx/.xls/.xlsm）调整Dir的后缀参数和截取文件名的长度。
• 如果不需要复制G列的表头，可将复制范围修改为G2:G" & lastRow。

内容的提问来源于stack exchange，提问作者user20470612