用VBA将数据拆分保存成多个workbook

小行星B612612

小白求助， 有一页worksheet中的数据有多行， 从第4行开始，每500行保存为一个workbook, 名称为拆分1，拆分2，拆分3....

每个拆分出来的数据都带着原来worksheet前3行的字段及说明。
谢谢大神~~~~

gwjkkkkk

文件空？？？

LIUZHU

下载了一个空文件夹，没有看到任何附件

baofa2

1. Sub test0()
   
2.   
   
3.   Dim maxRow As Long, titleRow As Long
   
4.   
   
5.   titleRow = 3
   
6.   maxRow = titleRow + 500
   
7.   
   
8.   DoApp False
   
9.   
   
10.   Dim data, i As Long, j As Long, k As Long, rowSize As Long
    
11.   Dim strPath As String, strName As String, wks As Worksheet
    
12.   
    
13.   strPath = ThisWorkbook.Path & Application.PathSeparator & "分簿"
    
14.   If Dir(strPath, vbDirectory) = "" Then MkDir strPath
    
15.   strPath = strPath & Application.PathSeparator
    
16.   
    
17.   Set wks = ActiveSheet
    
18.   data = wks.Range("A1").CurrentRegion.Value
    
19.   
    
20.   rowSize = titleRow
    
21.   For i = titleRow + 1 To UBound(data)
    
22.     rowSize = rowSize + 1
    
23.     For j = 1 To UBound(data, 2)
    
24.       data(rowSize, j) = data(i, j)
    
25.     Next
    
26.     If rowSize = maxRow Then
    
27.       k = k + 1
    
28.       strName = "拆分" & k
    
29.       wks.Copy
    
30.       With ActiveWorkbook
    
31.         With .Worksheets(1)
    
32.           .Range("A1").Resize(rowSize, j - 1) = data
    
33.           .UsedRange.Offset(, j - 1).Clear
    
34.           .UsedRange.Offset(rowSize).Clear
    
35.           .DrawingObjects.Delete
    
36.           .Name = strName
    
37.         End With
    
38.         .SaveAs strPath & strName, 51
    
39.         .Close
    
40.       End With
    
41.       rowSize = titleRow
    
42.     End If
    
43.   Next
    
44.   
    
45.   If rowSize > titleRow Then
    
46.     k = k + 1
    
47.     strName = "拆分" & k
    
48.     wks.Copy
    
49.     With ActiveWorkbook
    
50.       With .Worksheets(1)
    
51.         .Range("A1").Resize(rowSize, j - 1) = data
    
52.         .UsedRange.Offset(, j - 1).Clear
    
53.         .UsedRange.Offset(rowSize).Clear
    
54.         .DrawingObjects.Delete
    
55.         .Name = strName
    
56.       End With
    
57.       .SaveAs strPath & strName, 51
    
58.       .Close
    
59.     End With
    
60.   End If
    
61.   
    
62.   Set wks = Nothing
    
63.   DoApp
    
64.   Beep
    
65. End Sub
    
66. 
    
67. Function DoApp(Optional b As Boolean = True)
    
68.   With Application
    
69.     .ScreenUpdating = b
    
70.     .DisplayAlerts = b
    
71.     .Calculation = -b * 30 - 4135
    
72.   End With
    
73. End Function

复制代码

3190496160

哪位大哥帮我看看excel怎么拆分每个文件都是1万个数据，每个文件第一行标题需要保留-Excel基础应用-ExcelHome技术论坛 -  https://club.excelhome.net/forum ... amp;_dsign=7c644ad4

小行星B612612

gwjkkkkk 发表于 2024-6-6 16:51
文件空？？？

不好意思，更新了，谢谢大神~~帮忙看看~~

小行星B612612

LIUZHU 发表于 2024-6-6 17:02
下载了一个空文件夹，没有看到任何附件

不好意思，更新了，谢谢大神~~帮忙看看~~

LIUZHU

拆分效果演示

LIUZHU

JSA代码，主要是JS可以对数组进行切片操作

1. function 拆分(){
   
2.         const arr=Range("a1").CurrentRegion.Value2;
   
3.         const bt=arr.slice(0,3);
   
4.         let i=-1;
   
5.         [Application.DisplayAlerts,Application.ScreenUpdating]=[false,false];
   
6.         while(true){
   
7.                 let min=++i*500 + 3, max=min + 500;
   
8.                 if (min>arr.length) break;
   
9.                 let res=bt.concat(arr.slice(min,max));
   
10.                 Workbooks.Add().SaveAs(`${ThisWorkbook.Path}\\${String(i+1).padStart(3,"0")}.xlsx`);
    
11.                 Range("a1").Resize(res.length,res[0].length).Value2=res;
    
12.                 ActiveWorkbook.Close(true);
    
13.         }
    
14.         [Application.DisplayAlerts,Application.ScreenUpdating]=[true,true];
    
15. }

复制代码

LIUZHU

附件，请审核，WPS