一个文件夹内多个文件汇总，并按照规则拆分，生成多个文件。

javierexcel

第一步，订单汇总                                
汇总文件夹内所有的文件，全部是xls格式，文件数量几十个上下。所有的文件排序都是一样的。                                
                                
                                
第二步，分析并拆分文件                                
根据T列的货号，分析数据，生成多个文件。                                
比如：7506427716A-N3，第一个"-"号前面的字母是A,                             
           710000820XA-架R4，第一个"-"号前面的字母是XA,  
           生成命名为"A+日期"的文件。     提取所有符合 A和XA的数据                           
         
           7030193164B-2-A-V-3，第一个"-"号前面的字母是B,                          
           710008623XB-38，第一个"-"号前面的字母是XB,                  
           并生成命名为“B+日期”的文件。           提取所有符合B和XB的数据           

      
规律是：第一个"-"号前面的字母，忽略"X"

自动生成在该文件夹内

订单汇总.rar (23.46 KB, 下载次数: 44)

2018-5-3 02:27 上传

点击文件名下载附件

liulang0808

http://club.excelhome.net/thread-1258425-1-1.html
遍历文件资料供参考。。。。。。

lsc900707

Sub 订单汇总()
    t = Timer
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.xls")
    Application.ScreenUpdating = False
    ReDim brr(1 To 100000, 1 To 22)
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            n = n + 1
            Set sh = GetObject(p & f).Sheets(1)
            Arr = sh.[a1].CurrentRegion
            Workbooks(f).Close False
            For i = 2 To UBound(Arr)
                m = m + 1
                For j = 1 To 22
                    brr(m, j) = Arr(i, j)
                Next
            Next
        End If
        f = Dir
     Loop
     Set sh = Nothing
     With Sheet1
         .Range("a3:v" & Rows.Count).ClearContents
         .[a3].Resize(m, 22) = brr
     End With
     Application.ScreenUpdating = True
     MsgBox "合并了" & n & "个工作簿的" & m & "行数据。" & "用时：" & Format(Timer - t, "0.00") & "秒"
End Sub

javierexcel

lsc900707 发表于 2018-5-3 09:39
Sub 订单汇总()
    t = Timer
    p = ThisWorkbook.Path & "\"

第二步的按照规律拆分，能帮我实现吗？

lsc900707

javierexcel 发表于 2018-5-3 11:20
第二步的按照规律拆分，能帮我实现吗？

晚上有时间再看吧。

LMY123

同夹多薄，合并与拆分

javierexcel

lsc900707 发表于 2018-5-3 12:27
晚上有时间再看吧。

好的，那我先谢谢您啦，

lsc900707

在本目录下先建好一个“拆分好的”的文件夹：

1. Sub 拆分文件()
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     arr = [a2].CurrentRegion
   
5.     Set Rng = [a2].Resize(, 22)
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     For i = 3 To UBound(arr)
   
8.         s = Right(Split(arr(i, 20), "-")(0), 1)
   
9.         If Not d.Exists(s) Then
   
10.             Set d(s) = Cells(i + 1, 1).Resize(1, 22)
    
11.         Else
    
12.             Set d(s) = Union(d(s), Cells(i + 1, 1).Resize(1, 22))
    
13.         End If
    
14.     Next
    
15.     k = d.Keys
    
16.     t = d.Items
    
17.     For i = 0 To d.Count - 1
    
18.         With Workbooks.Add
    
19.              Rng.Copy .Sheets(1).[a1]
    
20.              t(i).Copy .Sheets(1).[a2]
    
21.              .SaveAs Filename:=ThisWorkbook.Path & "\拆分好的" & k(i), FileFormat:=xlWorkbookDefault
    
22.              .Close
    
23.         End With
    
24.     Next
    
25.     Application.DisplayAlerts = True
    
26.     Application.ScreenUpdating = True
    
27.     MsgBox "完毕"
    
28. End Sub
    

复制代码

lsc900707

javierexcel 发表于 2018-5-3 13:02
好的，那我先谢谢您啦，

汇总和拆分效果详见附件：

javierexcel

lsc900707 发表于 2018-5-3 20:44
汇总和拆分效果详见附件：

谢谢老师，但是后期出现报错。
我先把Sheet1里的A3:V25删除，再点击拆分文件，出现报错。