免费批量Excel文件合并、拆分工具

软件介绍


下载地址:https://pan.quark.cn/s/ae860a4e2ccb


1.多个XLS或XLSX格式EXCEL文件合并,合并后可使用数据透视表进行相关操作。
2.自动合并多个EXCEL文件的第一个工作表,并汇总成一张表,可根据所有列标题需要指定需要的列。
3.可汇总标准的EXCEL表格及两行标题并有合并单元格的EXCEL表格。
4.可对Excel文件进行拆分,支持复杂表头的拆分。

  • 10
    点赞
  • 0
    收藏
    觉得还不错? 一键收藏
  • 0
    评论
以下是一个将多个工作簿合并到一个工作表的VBA代码: ``` Sub MergeWorkbooks() Dim MyPath As String, FilesInPath As String Dim MyFiles() As String Dim SourceRcount As Long, FNum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim rnum As Long, CalcMode As Long ' Change this to the path\folder location of your files. MyPath = "C:\MyDocuments\" ' Add a slash at the end of the path if needed. If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" End If ' Set the file filter to find Excel files. FilesInPath = "*.xlsx*" ' Set the first result file number to 0. FNum = 0 ' Loop through all files in the folder. If Dir(MyPath & FilesInPath) = "" Then MsgBox "No files found." Exit Sub End If ' Turn off calculation and screen updating. With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With ' Set the base worksheet for the merge. Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) ' Loop through all files. Do While Dir(MyPath & FilesInPath) <> "" ' Add to the file count. FNum = FNum + 1 ' Re-dimension the array to hold the new file name. ReDim Preserve MyFiles(1 To FNum) ' Store the file name. MyFiles(FNum) = Dir(MyPath & FilesInPath) ' Go to the next file name. DirCount = DirCount + 1 Dir Loop ' Set the starting row for the copy. rnum = 1 ' Loop through all files and worksheets, copying the data to the base worksheet. For FNum = 1 To UBound(MyFiles) Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) For Each sourceSheet In mybook.Worksheets ' Find the last row of data on the source worksheet. SourceRcount = sourceSheet.Cells(Rows.Count, "A").End(xlUp).Row ' Set the source range. Set sourceRange = sourceSheet.Range("A1:Z" & SourceRcount) ' Copy the data to the base worksheet. Set destrange = BaseWks.Range("A" & rnum) sourceRange.Copy destrange ' Increase the row counter. rnum = rnum + SourceRcount Next sourceSheet mybook.Close savechanges:=False Next FNum ' Turn on calculation and screen updating. With Application .Calculation = CalcMode .ScreenUpdating = True End With ' Auto-fit the columns on the base worksheet. BaseWks.Columns.AutoFit End Sub ``` 以下是将工作表拆分为多个工作簿的VBA代码: ``` Sub SplitWorkbook() Dim FileExtStr As String Dim FileFormatNum As Long Dim xWs As Worksheet Dim xWb As Workbook Dim FolderName As String Dim Lrow As Long Dim OutFolder As String ' Change this to the path\folder location where you want to save the new files. OutFolder = "C:\MyDocuments\" ' Create a new folder for the output files. If Len(Dir(OutFolder, vbDirectory)) = 0 Then MkDir OutFolder End If ' Only save the active sheet. Set xWs = Application.ActiveSheet ' Get the file extension and format number. FileExtStr = ".xlsx" FileFormatNum = 51 ' Find the last row of data on the active sheet. Lrow = xWs.Cells(xWs.Rows.Count, "A").End(xlUp).Row ' Turn off calculation and screen updating. Application.ScreenUpdating = False Application.DisplayAlerts = False ' Loop through each row of data and save each row to a new file. For i = 2 To Lrow ' Create a new workbook. Set xWb = Application.Workbooks.Add ' Save the new workbook to the output folder. FolderName = OutFolder & xWs.Cells(i, "A").Value & FileExtStr ' Save the active sheet to the new workbook in the output folder. xWs.Rows(i).Copy xWb.Worksheets(1).Range("A1").PasteSpecial xlPasteAll ' Save and close the new workbook. xWb.SaveAs FolderName, FileFormatNum xWb.Close False Next i ' Turn on calculation and screen updating. Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub ``` 注意,这些代码应该修改以适应您的具体情况。
评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

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

余额充值