,整夹合一(D盘的d文件夹),多表合一。
Dim ts9 As String
Dim ArrFiles(1 To 10000) '创建一个数组空间,用来存放文件名称
Dim cntFiles% '文件个数
Dim o3 As Long
Public Function maxrow(xex)
axrow44 = Sheets(xex).[a65536].End(xlUp).Row
axrow45 = Sheets(xex).[b65536].End(xlUp).Row
If axrow44 > axrow45 Then
maxrow = axrow44
Else
maxrow = axrow45
End If
End Function
Public Sub 整夹合一() ''''id5'''(D盘的D文件夹)'''''''''''''''''''''''''''''''''''''''''''''''
Dim strPath$ '声明文件路径
Dim x, x2, f2, p3, i&
Dim k2, k3
Dim axx(1 To 1000)
Worksheets(1).Activate ''''新增一张表
Sheets.Add
Set fso = CreateObject("Scripting.FileSystemObject") ''''返回文件夹中的对象(文件包或子文件夹包)
strPath = "d:\d\" ''''D盘的D文件夹
cntFiles = 0
Set fd = fso.GetFolder(strPath) '设置fd文件夹对象
SearchFiles fd '调用子程序查搜索文件
ThisWorkbook.Sheets(1).Cells().Clear
Sheets(1).Range("a1").Resize(cntFiles) = Application.Transpose(ArrFiles) '把数组内的路径和文件名放在单元格中
k1 = cntFiles
p3 = 1
For x = 1 To k1 Step 1
If Right(ArrFiles(x), 3) = "xls" Or Left(Right(ArrFiles(x), 4), 3) = "xls" Then '''''只对电子表格类型进行移位合并
axx(p3) = x '所在的索引号
Set wk = Workbooks.Open(ArrFiles(x))
wk.Sheets().Move after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
p3 = p3 + 1
End If
Next x
End Sub
Sub SearchFiles(ByV) ''''id6+被调用的子程序。配合上一过程工作,才能完成同夹合一功能
Dim fl
Dim sfd
Set fso = CreateObject("Scripting.FileSystemObject") ''''返回文件夹中的对象(文件包或子文件夹包)
strPath = ByV
Set fd = fso.GetFolder(strPath) '设置fd文件夹对象
For Each fl In fd.Files '通过循环把文件逐个放在数组内,意思是循环文件包中的每一个对象
cntFiles = cntFiles + 1
ArrFiles(cntFiles) = fl.Path
Next fl
If fd.SubFolders.Count = 0 Then
Exit Sub
End If
For Each sfd In fd.SubFolders '''意思是循环文件夹包中的每一个对象
SearchFiles sfd
Next sfd
End Sub
Sub 多表合一() ''''id7
Dim m, n, o, i As Long '任务说明:采用复制粘贴的办法合并一个excel文件中的所有表为一张表,以便整理为数据库格式。
Dim a(1 To 100) As Long
Dim b(1 To 100) As Long
Dim s1, s2, f1, f2 As Long
Worksheets(1).Activate ''''
Sheets.Add
s2 = 1
i = Worksheets.Count 'i=表的张数
Sheets(1).Select '仅取A列为参考,最容易出错。取10列中最大值
o = maxrow(1)
If o > 1 Or o = 1 Then
For s1 = s2 To o '编码
Cells(s1, 254) = "源自本工作簿第00001张表"
Next
End If
For m = 2 To i
Sheets(1).Activate '''''仅取A列为参考,最容易出错。取10列中最大值
o = maxrow(1)
If Sheets(m).Name Like "*源码*" Then ''''源表不进行合并
Else
Sheets(m).Activate ''''
n = maxrow(m)
Sheets(m).Activate ''''
Rows(1 & ":" & n).Select
Range("A" & n).Activate
Application.CutCopyMode = False
Selection.Copy
Sheets(1).Select
o = maxrow(1)
Rows(o + 2 & ":" & o + 2 + n - 1).Select
ActiveSheet.Paste
Range("A" & o + n + 1).Select
Application.CutCopyMode = False
s2 = o + 1
For s1 = s2 To o + n + 5 '编码,主要用于跟踪数据来源
Cells(s1, 254) = "源自本工作簿第0000" & m & "张表"
Next s1
End If
Next m
End Sub
追问这个不是我要的呀。工作薄里面工作表个数不变,分别合并