将工作表中65536条数用VBA分割成2000行为一个文件报错

晓瞧流水

如下工作表的文件，一共有65536行，我要导入到ERP中的BOM但条目太多，导入就卡死，软件一次性只能支持2000条，我按2000为基数，网找上了一个VBA代码，执行，能分割但在最后报错，无法完全分割，报错如下图：


调试定位代码错误行如下图：


VBA宏代码在附件文件中，请大神老师指教，如何修改，或者有没有更好的办法分割。
2520V-BOM模板.rar (512.31 KB, 下载次数: 3)

2024-1-28 20:12 上传

点击文件名下载附件
原表

VAB代码：

1. Sub copybat()
   
2.     Dim i, j, k, m, r As Integer
   
3.     Dim n, total_data As Long
   
4.     Dim path As String
   
5.     Dim title_area, data_column, data_areas As Range
   
6.    
   
7.     Set title_area = Application.InputBox(prompt:="请用鼠标选择表头及表标题所在区域", Title:="选择", Type:=8) '选取表头区域
   
8.     Set data_column = Application.InputBox(prompt:="请鼠标选择需要拆分数据的开始行区域", Title:="选择", Type:=8) '选取拆分起始处
   
9.     m = data_column.Row      '获取分割开始行所在区域行号
   
10.     r = data_column.Column   '获取分割开始行所在区域列号
    
11.     j = data_column.Columns.Count   '获取分割开始行区域列数
    
12.     i = Application.InputBox(prompt:="请输入每次分割数据条目数", Title:="选择")
    
13.   
    
14.    '获取需要分割的数据总条数。这里，可以用两种办法获取到数据区域的尾部行号
    
15.       '第一种，使用传统的：End(xlDown).Row，优点是速度快，缺点是有空白行时会出错
    
16.       '第二种，使用查找方式find，优点是基本不会出错，缺点是条数较多时候可能会慢一点
    
17.    'total_data = Cells(data_column(1, 1)).End(xlDown).Row - m + 1
    
18.     total_data = Cells.Find("*", LookIn:=xlFormulas, SearchDirection:=xlPrevious).Row - m + 1
    
19.     If MsgBox("本次分割文件数据总数为:" & total_data & "条，将会被分割成" & WorksheetFunction.RoundUp(total_data / i, 0) & "个文件，" _
    
20.                 & "点击“确定”开始分割，点击“取消”返回", vbOKCancel, "确认") = vbOK Then
    
21.         Filename = Application.InputBox(prompt:="请输入分割后的文件主名，默认为“分割文件”", Title:="选择", Default:="分割文件")
    
22.         With Application.FileDialog(msoFileDialogFolderPicker)  '获取分割后的文件存储路径
    
23.             If .Show = False Then Exit Sub
    
24.                 path = .SelectedItems(1) & "" '加入"",否则，文件会被存储到选定路径的上一层
    
25.         End With
    
26.         Application.ScreenUpdating = False
    
27.         k = 0   '第几次分割输出，用于标识分割文件次数
    
28.         For n = m To total_data Step i   '从开始分割的行往下计数
    
29.             Set data_areas = Range(Cells(n, r), Cells(n + i - 1, j))   '设置每次循环体内的分割数据主体
    
30.             Application.Union(title_area, data_areas).Select           '把表头区域以及本次循环体内的数据区域进行合并
    
31.             Selection.Copy
    
32.             Workbooks.Add
    
33.             Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
    
34.             , SkipBlanks:=False, Transpose:=False      '特殊粘贴：包含源格式的粘贴，以便保持所有格式一致
    
35.            k = k + 1
    
36.            ActiveWorkbook.SaveAs Filename:=path & Filename & "_" & k & ".xlsx", FileFormat:= _
    
37.             xlOpenXMLWorkbook, CreateBackup:=False      '按照既有的文件名、路径、循环次数合并起来存储文件
    
38.             ActiveWindow.Close
    
39.         Next n
    
40.         MsgBox "文件分割完毕！", vbDefaultButton1, "提示"
    
41.     End If
    
42.     Application.ScreenUpdating = True
    
43. End Sub
    

复制代码

shiruiqiang

ai代码吧？就step 2000，直接复制到新excel，另存

晓瞧流水

shiruiqiang 发表于 2024-1-28 22:24
ai代码吧？就step 2000，直接复制到新excel，另存

我只是贴出来一部分，我还有十几万条的，复制死人的要

3190496160

Sub copybat()
Application.ScreenUpdating = False
lj = ThisWorkbook.path & "\"
Set sht = ActiveSheet
With sht
    r = 65536
    ar = .Range("a2:i" & r)
End With
On Error Resume Next
For i = 2 To UBound(ar) Step 2000
    m = m + 1
    Set wb = Workbooks.Add
    With wb.Worksheets(1)
        .Name = "分割文件" & "_" & m
        sht.Range("a1:i1").Copy .[a1]
        If i + 1999 <= 65536 Then
            sht.Range("a" & i & ":i" & i + 1999).Copy .[a2]
        Else
            sht.Range("a" & i & ":i65536").Copy .[a2]
        End If
    End With
    wb.SaveAs Filename:=lj & "分割文件_" & m
    wb.Close
Next i
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

2520V-BOM模板.rar (533.82 KB, 下载次数: 9)

2024-1-29 08:30 上传

点击文件名下载附件

准提部林

Rx=65536
for k=1 to Rx step 2000
    R=2000: if R > Rx then R=Rx
   cells(k,1).resize(R ,10).copy "指定位置"
    Rx = Rx -2000
next k

晓瞧流水

3190496160 发表于 2024-1-29 08:30

谢谢老师的帮助简单实用