用VBA对上万条明细按指定条件拆分成多个工作簿

ppzzww

背景：

1、 因开票数量很大，购买方300个左右，每个购买方有几百上千条货物明细，总明细12万条左右。

2、 税务局开票系统每次最多只导入4500条以下的明细。

3、 开票明细表中：“1-发票基本信息”为购买方信息，每个购买方一行且不重复；“2-发票明细信息”是所有购买方对应的货物明细。

4、 开票明细表中，每个工作表的1-3行为固定行抬头，行列固定。

需求：将以下条件拆分的数据生成到“开票模板”中，保持1-3行抬头不变。注“开票模板”与“开票明细”都一样，只是模版中无明细数据。

第1步：“开票明细”表中“2-发票明细信息”表进行拆分：

1)  先对A列（该列4行及以下行）进行升序排序，其他列同时扩展变化。

2)  对所行（4行及以下行），每隔4000条（建议以A列计数）拆分为新的工作簿，并保存到当前文件夹中，新工作簿名：自然序号+年月日+零件开票拆分，如”1-240523-零件开票拆分“。

第2步：“开票明细”表中“1-发票基本信息“表：根据“2-发票明细信息”拆分的购买方，删除本表中其他的购买方，只保留本次拆分的购买方行信息。例如：第一步中拆分明细中A列有4个购买方（去重），本表只保留这4个的信息，其他信息删除。

如此循环上述第1-2步，直到全部拆分完。

注意：

1、拆分后生成的新工作簿中的：1-发票基本信息“、2-发票明细信息、3-特定业务信息、4-附加要素信息，这四个工作表名都要保留且表名不变、1-3行固定行列内容保持不变。

2，第1步第2点是对4行以下的所有行列拆分到新工作簿中，不是只对A列拆分。
3，新的工作表跟原模板中的所有工作表名及工作表数量及每个工作表抬头一致。

ppzzww

补充：
1，第1步第2点是对4行以下的所有行列拆分到新工作簿中，不是只对A列拆分。
2，新的工作表跟原模板中的所有工作表名及工作表数量及每个工作表抬头一致。

ykcbf1100

不需要模板。

附件更新一下。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.5.23
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set d1 = CreateObject("scripting.dictionary")
   
6.     Set ws = ThisWorkbook
   
7.     fn = [{"1-发票基本信息","2-发票明细信息","3-特定业务信息","4-附加要素信息"}]
   
8.     Set sh = ws.Sheets("2-发票明细信息")
   
9.     p = ThisWorkbook.Path & ""
   
10.     With sh
    
11.         r = .Cells(Rows.Count, 1).End(3).Row
    
12.         Set Rng = .[a4].Resize(r - 3, 13)
    
13.         Rng.Sort .[a4], 1
    
14.         arr = Rng.Value
    
15.     End With
    
16.     p1 = 4000
    
17.     For i = 1 To r
    
18.         m = m + 1
    
19.         If i = 1 Then n = 1: d(1) = Array(1, IIf(r - 3 < p1, r - 3, p1))
    
20.         k = m / p1
    
21.         If Int(k) = k And k > 0 Then
    
22.             n = n + 1
    
23.             d(n) = Array(m + 1, IIf(m + p1 > UBound(arr), UBound(arr), m + p1))
    
24.         End If
    
25.     Next
    
26.     t = d.items
    
27.     rq = Format(Date, "yymmdd")
    
28.     On Error Resume Next
    
29.     For k = 1 To d.Count
    
30.         ws.Sheets(fn).Copy
    
31.         Set wb = ActiveWorkbook
    
32.         m = 0
    
33.         ReDim brr(1 To 4000, 1 To 13)
    
34.         d1.RemoveAll
    
35.         With wb.Sheets(sh.Name)
    
36.             .DrawingObjects.Delete
    
37.             For i = d(k)(0) To d(k)(1)
    
38.                 m = m + 1
    
39.                 For j = 1 To UBound(arr, 2)
    
40.                     brr(m, j) = arr(i, j)
    
41.                 Next
    
42.                 s = brr(m, 1)
    
43.                 d1(s) = ""
    
44.             Next
    
45.             .Columns(3).NumberFormatLocal = "@"
    
46.             .[a4].Resize(m, 13) = brr
    
47.             .UsedRange.Offset(m + 3).Clear
    
48.         End With
    
49.         c = 0
    
50.         With wb.Sheets(fn(1))
    
51.             r = .Cells(Rows.Count, 1).End(3).Row
    
52.             crr = .[a4].Resize(r - 3, 26)
    
53.             .UsedRange.Offset(3).ClearContents
    
54.             ReDim zrr(1 To UBound(crr), 1 To UBound(crr, 2))
    
55.             For i = 1 To UBound(brr)
    
56.                 s = crr(i, 1)
    
57.                 If d1.exists(s) Then
    
58.                     c = c + 1
    
59.                     For j = 1 To UBound(crr, 2)
    
60.                         zrr(c, j) = crr(i, j)
    
61.                     Next
    
62.                 End If
    
63.             Next
    
64.             .Columns(3).NumberFormatLocal = "@"
    
65.             .[a4].Resize(c, 26) = zrr
    
66.         End With
    
67.         wb.SaveAs p & k & "-" & rq & "-零件开票拆分"
    
68.         wb.Close
    
69.     Next
    
70.     Set d = Nothing
    
71.     Application.ScreenUpdating = True
    
72.     MsgBox "OK！"
    
73. End Sub
    

复制代码

半百

两表同时打开，没有排序语句，请手动排序后运行开票明细里的过程test。

ppzzww

ykcbf1100 发表于 2024-5-23 16:07
不需要模板。

附件供参考。。。

感谢，大哥。
我发现拆分的工作簿有以下问题：
1、第一个拆分的明细是4000条，但从第二个拆分的表开始就是8000，12000，而不是每个拆分的表明细都是4000或以下。（我需要拆分出来的每个表最多不超过4000行）

2、“1-发票基本信息”，这个表没有任何变化，麻烦看看能做到以下要求吗？相当于“2-发票明细信息”拆分后，”1-发票基本信息”这个表也同时按以下要求更新。
条件：“1-发票基本信息“表：根据“2-发票明细信息”拆分的购买方，删除本表中其他的购买方（A列），只保留本次拆分的购买方行信息。例如：本次拆分后“2-发票明细信息”中A列有4个购买方（去重），本表“1-发票基本信息“表只保留这4个的信息，其他信息删除。

3、麻烦生成的新工作簿自动放在当前文件夹中。

ppzzww

半百 发表于 2024-5-23 16:19
两表同时打开，没有排序语句，请手动排序后运行开票明细里的过程test。

谢谢，能否对在目前的基础上对”1-发票基本信息”实现以下要求，谢谢。

“1-发票基本信息”，这个表没有任何变化，麻烦看看能做到以下要求吗？相当于“2-发票明细信息”拆分后，”1-发票基本信息”这个表也同时按以下要求更新。
条件：“1-发票基本信息“表：根据“2-发票明细信息”拆分的购买方，删除本表中其他的购买方（A列），只保留本次拆分的购买方行信息。例如：本次拆分后“2-发票明细信息”中A列有4个购买方（去重），本表“1-发票基本信息“表只保留这4个购买方的信息，其他购买方信息删除。

ykcbf1100

ppzzww 发表于 2024-5-23 16:51
感谢，大哥。
我发现拆分的工作簿有以下问题：
1、第一个拆分的明细是4000条，但从第二个拆分的表开始 ...

代码更新。。。

半百

ppzzww 发表于 2024-5-23 17:24
谢谢，能否对在目前的基础上对”1-发票基本信息”实现以下要求，谢谢。

“1-发票基本信息”，这个表没 ...

不好意思，后边加两句

ppzzww

ykcbf1100 发表于 2024-5-23 19:52
代码更新。。。

太完美了，另外，有一个需要变化，麻烦再帮忙看看（最后一个需求，其他需求不变）
：
表”2-发票明细信息“，第每一个4000行拆分时，可能会出现A列同一个购买方被拆分到下一个表中，能否判断一下，如果拆分时A列同一个购买方明细刚好被拆分，刚本次不取4000行拆分，而是折分到最近的一个购买方，本次不拆分就放到下一个拆分表中。

其实简单理解就是：A列的同一个购买方放在一起，即一个表中（不会被拆分到下一表中），且不超过4000行。