按特定行数分割成多个文件

cxkaka

求助各位大神，我有一个原始文件如下图：

现在想要通过macro实现以下效果：
同一个PO NO，每五行分隔成一个单独的带表头的Excel文件（保存在原文件同一个文件夹中），并以PO NO-1, -2, -3这样的形式命名。

New Microsoft Excel Worksheet.zip (9.94 KB, 下载次数: 8)

2024-12-11 09:40 上传

点击文件名下载附件

万分感谢！！！

chxw68

详见附件。

飞天篮球猪

插件解法...仅供参考...

xlj310

这不是系统自带的一个功能吗？ 现在用还是免费的。 不需要VIP啊。 只不过C列是保留的。

cxkaka

chxw68 发表于 2024-12-11 09:56
详见附件。

大神用你这个宏跑出来的貌似每个文件里的内容都是重复的，能帮忙看一下吗

chxw68

确实有错误。修改好了。

chxw68

用字典写一下，纯属练习。

chxw68

字典法不要求对A列数据事先排序。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.12.11
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim zrr(1 To 1000)
   
5.     p = ThisWorkbook.Path & ""
   
6.     rr = 5: bt = 1: c = 2
   
7.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
8.     With sh
   
9.         r = .UsedRange.Find("*", , -4163, , 1, 2).Row
   
10.         arr = .[a1].Resize(r, c)
    
11.         Set bth = .Rows(bt).EntireRow
    
12.     End With
    
13.     For i = bt + 1 To UBound(arr)
    
14.         If arr(i, 1) <> arr(i - 1, 1) Then m = m + 1: zrr(m) = Array(i, i)
    
15.         If i = r Then zrr(m)(1) = r
    
16.         If i < r Then
    
17.             If arr(i, 1) = arr(i - 1, 1) And arr(i, 1) <> arr(i + 1, 1) Then zrr(m)(1) = i
    
18.         End If
    
19.     Next
    
20.     Application.SheetsInNewWorkbook = 1
    
21.     For x = 1 To m
    
22.         r1 = zrr(x)(0): r2 = zrr(x)(1)
    
23.         n = r2 - r1 + 1
    
24.         numSheets = Int(n / rr) + 1
    
25.         k = 0
    
26.         For i = 1 To numSheets
    
27.             k = k + 1
    
28.             rr1 = r1 + (i - 1) * rr
    
29.             rr2 = Application.Min(r1 + i * rr - 1, r2)
    
30.             Set wb = Workbooks.Add
    
31.             With Sheets(1)
    
32.                 bth.Copy .[a1]
    
33.                 Set Rng = sh.Range(sh.Cells(rr1, 1), sh.Cells(rr2, c))
    
34.                 Set destRange = .[a2]
    
35.                 Rng.Copy Destination:=destRange
    
36.             End With
    
37.             wb.SaveAs Filename:=p & arr(r1, 1) & "-" & k
    
38.             wb.Close
    
39.         Next
    
40.     Next
    
41.     Application.ScreenUpdating = True
    
42.     MsgBox "OK！"
    
43. End Sub
    

复制代码