Excel:vba实现合并工作簿中的表

A、B、C这三个工作簿的数据都在sheet1,表头一样

复制代码
Sub MergeWorkbooks()
    Dim FolderPath As String
    Dim FileName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim mainWb As Workbook
    Dim mainWs As Worksheet
    Dim lastRow As Long
    Dim lastcol As Long
    
    Dim pasteRange As Range

    ' 主工作簿设置为当前工作簿
    Set mainWb = ThisWorkbook
    Set mainWs = mainWb.Sheets(1) ' 假设数据合并到第一张表中
    
    mainWs.Cells.Clear

    ' 获取文件夹路径(你可以根据需求修改文件夹路径)
    'FolderPath = "D:\VBA\hebin\" ' 更改为你实际存储文件的路径
    FolderPath = ThisWorkbook.Path & "\"

    ' 确保路径以反斜杠结尾
    If Right(FolderPath, 1) <> "\" Then
        FolderPath = FolderPath & "\"
    End If

    ' 获取第一个Excel文件
    FileName = Dir(FolderPath & "*.xlsx")
    
    ' 如果找不到任何文件,则提示并退出
    If FileName = "" Then
        MsgBox "未找到任何Excel文件,请检查路径或文件格式。"
        Exit Sub
    End If

    ' 循环所有Excel文件
    Do While FileName <> mainWb.Name
        ' 打开工作簿
        On Error Resume Next
        Set wb = Workbooks.Open(FolderPath & FileName)
        If Err.Number <> 0 Then
            MsgBox "无法打开文件:" & FileName
            Err.Clear
            Exit Sub
        End If
        On Error GoTo 0
        
        ' 假设数据在每个工作簿的第一张表中,找到最后一行并复制数据
        Set ws = wb.Sheets(1)
        lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        lastcol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        
        ws.Cells(1, 1).Resize(1, lastcol).Copy Destination:=mainWs.Cells(1, 1)
        
        ' 查找主工作簿中当前的最后一行
        If Application.WorksheetFunction.CountA(mainWs.Cells) > 0 Then
            Set pasteRange = mainWs.Cells(mainWs.Rows.Count, 1).End(xlUp).Offset(1, 0)
        Else
            Set pasteRange = mainWs.Cells(1, 1)
        End If

        ' 复制工作簿中的数据并粘贴到主工作簿
        'ws.Range("A1:" & ws.Cells(lastcol, lastRow).Address).Copy
        ws.Range("A2:E" & lastRow).Copy
        mainWs.Paste Destination:=pasteRange

        ' 关闭工作簿(不保存)
        wb.Close False

        ' 获取下一个文件
        FileName = Dir
    Loop
    
    With mainWs.Cells
        .HorizontalAlignment = xlCenter '设置水平居中
        .VerticalAlignment = xlCenter '设置垂直居中
        .Font.Size = 14
    End With

    ' 完成后提示
    MsgBox "所有工作簿已成功合并!"
End Sub

循环获取文件夹中的每个文件

复制代码
Sub ListFiles()
    Dim fileName As String
    ' 第一次调用 Dir 并传入路径,获取第一个文件
    fileName = Dir(ThisWorkbook.Path & "/")
    
    ' 使用循环,逐步获取下一个文件
    Do While fileName <> ""
        MsgBox fileName   ' 显示文件名
        fileName = Dir    ' 不带参数,获取下一个文件
    Loop
End Sub
'如果想要获取路径,就Thisworkbook.Path & "/" & filename 
相关推荐
我命由我123455 小时前
Excel 表格 - Excel 减少干扰、专注于内容的查看方式
学习·ui·excel·photoshop·表格·ps·美工
北风toto5 小时前
excel数字转文本样式不生效问题
excel
我命由我123455 小时前
Excel 表格 - Excel 单元格添加边框
学习·ui·excel·课程设计·photoshop·ps·美工
admin⁠5 小时前
php 实现 导入excel 带图片导入
php·excel
葡萄城技术团队5 小时前
SpreadJS:让多源数据筛选排序如 Excel 般便捷高效
运维·服务器·excel
Developer-YC6 小时前
像素图生成小程序开发全解析:从图片上传到Excel图纸
java·javascript·图像处理·微信小程序·excel
懵逼的小黑子1 天前
excel里面店铺这一列的数据结构是2C【uniteasone17】这种,我想只保留前面的2C部分,后面的【uniteasone17】不要
excel
偷心伊普西隆1 天前
Python EXCEL 理论探究:格式转换时处理缺失值方法
python·excel
CodeCraft Studio2 天前
Excel处理控件Aspose.Cells教程:使用 Python 将 Pandas DataFrame 转换为 Excel
python·json·excel·pandas·csv·aspose·dataframe
星空的资源小屋2 天前
PPTist,一个完全免费的 AI 生成 PPT 在线网站
人工智能·python·电脑·excel