|
这种简单合并用复制粘贴很快的,只要不超过20个表的数据,复制粘贴就是几分钟的事情;
既然在这里回复了,也不能只是说说,给你写了个简单的代码,放在主表中运行:
Application.ScreenUpdating = False
Dim arr
arr = GetFiles(ThisWorkbook.Path)
s1 = UCase(ThisWorkbook.Name)
s2 = Mid(s1, InStr(s1, ".XL") - 3, 3)
If [a100000].End(3).Row > 1 Then
Range(Cells(2, 1), Cells([a100000].End(3).Row, 6)).ClearContents
End If
Dim wb As Workbook
For i = 1 To UBound(arr)
If InStr(arr(i), s2) = 0 Then
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & arr(i))
For k = 1 To wb.Worksheets.Count
wb.Worksheets(k).Activate
Range("a4:e" & wb.Worksheets(k).[a100000].End(3).Row).Copy
ThisWorkbook.Activate
Range("b" & [a100000].End(3).Row + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
For j = [a100000].End(3).Row + 1 To [b100000].End(3).Row
Cells(j, 1) = Mid(Cells(j, 2), 1, 1) & "公司"
Next j
Next k
wb.Close
End If
Next i
Application.ScreenUpdating = True
End Sub
Function GetFiles(myPath As String)
Dim myArr()
myJs = 0
Set myFolder = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
For Each mySubfile In myFolder.Files
myJs = myJs + 1
ReDim Preserve myArr(1 To myJs)
myArr(UBound(myArr)) = mySubfile.Name
Next
GetFiles = myArr
End Function
有两个问题:
1、你把主表的名称叫做“需要得到的结果.xlsx”,这种叫法很碍事,我也不知道真正的文件名是什么,代码过滤也就这么来了,自己修改:
s2 = Mid(s1, InStr(s1, ".XL") - 3, 3)
为了预防主表文件名称的飘忽不定,我想弄得智能化一点,所以截取了从扩展名往前的3个字符作为过滤条件,这里就有个问题:如果你的文件名称只有2个文字呢,比如“主表.xls”或者“汇总.xls”,那就有问题了,要把数字3改成数字2;
能不能截取更长一点或者更短一点呢?都有缺陷,比如主表叫“汇总数据”,明细表叫“明细数据”,截取两位反而分不开了,必须3以上才行;
总之就是要你的文件命名规范就行了,不论随便乱叫,因为主表是不能重复打开的,在打开明细表的时候,需要把主表自己过滤掉;
2、另一个问题是,a列添加的都是"a公司"、“b公司”这些,这名称我也不知道哪来的,你的子文件是分公司1、分公司2...所以我琢磨半天,只有合同号里面有字母a\b\c\d,所以我就截取了合同编号的第一个字母+“公司”,我估摸着也不像,反正看不懂,你将就试一下吧;
|
评分
-
查看全部评分
|