利用VBA快速整合多个excel文件
心得(一):关于VBA如何把同一个文件下的所有文件的内容合并到同一个excel文件下问题:如何把多个格式相同的excel整合到一个excel上,起初想的是可以直接用复制粘贴……但是文件有几百个将近一千个,这么做的话有点暴躁…解决:首先把所有要整合的excel文件放在一个路径不含有中文名的目录下,然后新建一个excel文件右键sheet点击查看代码,这时候你的画面上会出现一个编辑器,你这这上面利..
·
心得(一):关于VBA如何把同一个文件下的所有文件的内容合并到同一个excel文件下
问题:如何把多个格式相同的excel整合到一个excel上,起初想的是可以直接用复制粘贴……但是文件有几百个将近一千个,这么做的话有点暴躁…
解决:首先把所有要整合的excel文件放在一个路径不含有中文名的目录下,然后新建一个excel文件右键sheet点击查看代码,这时候你的画面上会出现一个编辑器,你这这上面利用VBA编写语言,最后点击F5直接运行即可
正常解决思路:
打开一个excel文件,并将需要的内容复制,然后粘贴到整合excel文件上,并不断重复这样的操作。
利用VBA操作:
-
利用VBA打开文件,代码如下:

括号内的是打开文件的绝对地址 -
复制选定区域的内容:

-
粘贴复制的内容到指定的文件

-
利用VBA的dir函数打开下一个文件,这个函数会根据一定规律打开文件内的文件,但是具体是什么规律暂时还不知道,
这个函数如果是这个方式:
第首次使用就要输入绝对地址,但是后面就不需要了
源码如下:
Sub 合并当前目录下所有工作簿的全部工作表()
'表示当前的过程的名称
'定义对应的变量名称
Dim mypath, myname, awbname
Dim wb As Workbook, wbn As String
Dim g As Long
Dim num As Long
Dim box As String
Dim count As Long
Dim place As Long
Dim temp As Long
'关闭excel的刷新
Application.ScreenUpdating = False
'禁止弹出对话框
Application.DisplayAlerts = False
'得到本文件的相对地址
mypath = ActiveWorkbook.Path
'得到这个文件夹下的某个文件的文件名
myname = Dir(mypath & "\" & "*.xls")
'当前工作的excel的文件名
awbname = ActiveWorkbook.Name
num = 0
place = 3
'如果当前的文件名为空的字符串("")表示已经没有更多的文件了跳出循环
Do While myname <> ""
'需要的就是下面这个条件,每个文件名都不一样
If myname <> awbname Then
'把每一个文件都打开
Set wb = Workbooks.Open(mypath & "\" & myname)
num = num + 1
'计算非空行数量
count = application.counta(range("c:c"))
'MsgBox count
wb.Sheets(1).Range("a5", wb.Sheets(1).Cells.SpecialCells(xlCellTypeLastCell)).Copy
'从a5开始到已用区域最后一个单元格的范围全部复制
ThisWorkbook.Sheets(1).Cells(ThisWorkbook.Sheets(1).Range("C65536").End(xlUp).Row + 2 , 1).PasteSpecial Paste:=xlValues
'从c列最后一个有数据的单元格后的空格开始粘贴
'下面开始合并需要的单元格
temp = count + place - 2
ThisWorkbook.Sheets(1).Range("A" & place & ":A" & temp).Merge
ThisWorkbook.Sheets(1).Range("B" & place & ":B" & temp).Merge
ThisWorkbook.Sheets(1).Range("H" & place & ":H" & temp).Merge
ThisWorkbook.Sheets(1).Range("I" & place & ":I" & temp).Merge
'对每个队伍重新编号
ThisWorkbook.Sheets(1).Range("A" & place).Value = num
place = place + count
wbn = wbn & Chr(13) & wb.Name
wb.Close False
End If
myname = Dir
Loop
Range("a1").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "共合并了" & num & "个工作薄下的全部工作表。'如下:" & Chr(13) & wbn, vbInformation, "提示"
End Sub
更多推荐


所有评论(0)