vb整合多个excel表格到一张_vba实现excel多表合并

Excel多表合并之vba实现

需求

保留列名,复制每一个excel里的数据,合并到一个excel

操作步骤

将要合并的文件放在同一文件夹下,复制过来就好(ps:最好不要直接操作原数据文件,避免操作失败,数据丢失)

在这个目录下创建一个“合并.xlsx”

双击打开“合并.xlsx”

同时按 ALT + F11

出现下图,按图中文字操作即可完成合并

完成

附录代码

Sub合并当前目录下所有工作簿的全部工作表()DimMyPath, MyName, AWbNameDim Wb As Workbook, WbN As String

Dim G As Long

Dim Num As Long

Dim BOX As Stringflag= 0Application.ScreenUpdating= FalseMyPath=ActiveWorkbook.Path

MyName= Dir(MyPath & "\" & "*.xls")

AWbName=ActiveWorkbook.Name

Num= 0

Do While MyName <> ""

If MyName <> AWbName Then

Set Wb = Workbooks.Open(MyPath & "\" &MyName)

Num= Num + 1

With Workbooks(1).ActiveSheetFor G = 1 ToSheets.CountIf flag = 0 ThenWb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row , 1)

flag= 1

ElseWb.Sheets(G).Range("a2", Wb.Sheets(G).Cells.SpecialCells(xlCellTypeLastCell)).Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)End If

NextWbN= WbN & Chr(13) &Wb.Name

Wb.CloseFalse

End With

End IfMyName= Dir

LoopRange("A1").Select

Application.ScreenUpdating= True

MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下:" & Chr(13) & WbN, vbInformation, "提示"

End Sub

合并多个excel每个excel有多个sheet,每个sheet单独合并,代码如下

Sub 合并当前目录下所有工作簿的全部工作表()

Dim MyPath, MyName, AWbName

Dim Wb As Workbook, WbN As String

Dim G As Long

Dim Num As Long

Dim BOX As String

flag = 0

Application.ScreenUpdating = False

MyPath = ActiveWorkbook.Path

MyName = Dir(MyPath & "\" & "*.xls")

AWbName = ActiveWorkbook.Name

Num = 0

Do While MyName <> ""

If MyName <> AWbName Then

Set Wb = Workbooks.Open(MyPath & "\" & MyName)

Num = Num + 1

For G = 1 To Wb.Sheets.Count

If flag = 0 Then

Sheets.Add after:=Sheets(Sheets.Count)

With ActiveSheet

.Name = Wb.Sheets(G).Name

Wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row, 1)

.UsedRange.Rows.AutoFit

.UsedRange.Columns.AutoFit

End With

Else

With Workbooks(1).Worksheets(G + 3)

' MsgBox .Name & "--" & Wb.Sheets(G).Name

If G = 2 Then

Wb.Sheets(G).Range("a2", Wb.Sheets(G).Cells.SpecialCells(xlCellTypeLastCell)).Copy .Cells(.Range("A65536").End(xlUp).Row + 2, 1)

Else

Wb.Sheets(G).Range("a2", Wb.Sheets(G).Cells.SpecialCells(xlCellTypeLastCell)).Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)

End If

.UsedRange.Rows.AutoFit

.UsedRange.Columns.AutoFit

End With

End If

Next

'flag 为0时候为第一个打开的excel,此时产生列,sheet名

flag = 1

WbN = WbN & Chr(13) & Wb.Name

Wb.Close False

' End With

End If

MyName = Dir

Loop

Range("A1").Select

Application.ScreenUpdating = True

MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下:" & Chr(13) & WbN, vbInformation, "提示"

End Sub

参与评论 您还未登录,请先 登录 后发表或查看评论

“相关推荐”对你有帮助么?

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
©️2022 CSDN 皮肤主题:游动-白 设计师:我叫白小胖 返回首页

打赏作者

weixin_39736606

你的鼓励将是我创作的最大动力

¥2 ¥4 ¥6 ¥10 ¥20
输入1-500的整数
余额支付 (余额:-- )
扫码支付
扫码支付:¥2
获取中
扫码支付

您的余额不足,请更换扫码支付或充值

打赏作者

实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、C币套餐、付费专栏及课程。

余额充值