如何根据一列编码将一个excel拆分为多个500条数据的excel文件？

peaxenia

请各位帮忙看一下如何根据一列编码将一个excel拆分为多个500条数据的excel文件？
具体要求请见附件，谢谢帮助！

魂断蓝桥

根据B列编码拆分为500行一个Excel文件，例如BP4 500个，但同一个拆分文件仅保留一个编码，如BP4最终有100个，单独拆分，不与其他编码混在一起

没看懂？

如果有501条数据，如何拆分呢，一个500条，一个一条。

并且最终拆分文件命名为自定义名称+B列对应编码+对应编码文件序号
对应编码文件序号如BP4拆分了20个文件，编号依次由1-20

能举个例子吗？

peaxenia

魂断蓝桥 发表于 2016-7-6 11:16
根据B列编码拆分为500行一个Excel文件，例如BP4 500个，但同一个拆分文件仅保留一个编码，如BP4最终有100个 ...

比如BP4有1100条数据，BP5有800条数据
最终拆分结果为5个文件，文件名及数据量如下：
自定义名称-BP4-1 500
自定义名称-BP4-2 500
自定义名称-BP4-3 100
自定义名称-BP5-1 500
自定义名称-BP5-2 300

peaxenia

顶一下，求帮助

魂断蓝桥

peaxenia 发表于 2016-7-6 11:48
顶一下，求帮助

代码有一个问题，数据中有bm1的数据的时候，
运行到bm1的第17个表格，就会出错，
调试了好长时间，没有结果，也不知道是什么原因，
如果表格中只保留bm1，拆分没有问题，实在是不知道怎么办了。

楼主自己测试一下吧。

实在不行，先把bm1 删除，拆分完后，再把bm1粘贴回来，再拆






Sub 拆分()
Dim i&, j%, d, arr, k, m%, tim
tim = Timer
Set d = CreateObject("Scripting.Dictionary")
arr = [a1].CurrentRegion
Application.ScreenUpdating = False
For i = 1 To UBound(arr)
    d(arr(i, 2)) = d(arr(i, 2)) + 1
Next
k = d.keys
Dim cnn, rs As Object, Sql As String, wb As Workbook
Set cnn = CreateObject("adodb.connection")
cnn.Open "Provider=Microsoft.ACE.OleDb.12.0;Extended Properties='Excel 12.0;HDR=NO'; Data Source=" & ThisWorkbook.FullName
For j = 0 To UBound(k)
    Sql = "select * from [sheet1$a1:c] where F2='" & k(j) & "'"
    Set rs = cnn.Execute(Sql)
        For m = 1 To (d(k(j)) / 500 + 0.5) \ 1
            Set wb = Workbooks.Add
                arr = rs.GetRows(500, 0)
                Range("a1").Resize(UBound(arr, 2) + 1, 3) = Application.Transpose(arr)
                wb.SaveAs ThisWorkbook.Path & "\分表\" & "自定义名称-" & k(j) & "-" & m & " " & UBound(arr, 2) + 1
                wb.Close True
        Next
Next
Application.ScreenUpdating = True
Set d = Nothing
Set rs = Nothing
Set cnn = Nothing
End Sub

peaxenia

魂断蓝桥 发表于 2016-7-6 14:19
代码有一个问题，数据中有bm1的数据的时候，
运行到bm1的第17个表格，就会出错，
调试了好长时间，没有 ...

谢谢，但还是不行，编码非常多，还有其他编码也运行到17个就会出错。

魂断蓝桥

peaxenia 发表于 2016-7-6 16:27
谢谢，但还是不行，编码非常多，还有其他编码也运行到17个就会出错。

其中原因，我也不太清楚了。

魂断蓝桥

peaxenia 发表于 2016-7-6 16:27
谢谢，但还是不行，编码非常多，还有其他编码也运行到17个就会出错。

终于搞明白了。

因为楼主的数据超出65536 excel2003的限制，在excel2010 中，虽然行数增加到100多万，但用 【sheet1$A:C】这种形式，只能取到65535的数据，其余的不能得出，所以，需要用[SHEET1$] 这种写法。

拆分出137个分表

新建文件夹.part1.rar (1.39 MB, 下载次数: 22)

2016-7-6 20:28 上传

点击文件名下载附件

新建文件夹.part2.rar (732.39 KB, 下载次数: 22)

2016-7-6 20:28 上传

点击文件名下载附件

代码改成

Sub 拆分()
Dim i&, j%, d, arr, k, m%, tim
tim = Timer
Set d = CreateObject("Scripting.Dictionary")
arr = [a1].CurrentRegion
Application.ScreenUpdating = False
For i = 1 To UBound(arr)
    d(arr(i, 2)) = d(arr(i, 2)) + 1
Next
k = d.keys
Dim cnn, rs As Object, Sql As String, wb As Workbook
Set cnn = CreateObject("adodb.connection")
cnn.Open "Provider=Microsoft.ACE.OleDb.12.0;Extended Properties='Excel 12.0;HDR=NO'; Data Source=" & ThisWorkbook.FullName
For j = 0 To UBound(k)
    Sql = "select * from [sheet1$] where F2='" & k(j) & "'"
    Set rs = cnn.Execute(Sql)
        For m = 1 To (d(k(j)) / 500 + 0.5) \ 1
            Set wb = Workbooks.Add
                arr = rs.GetRows(500, 0)
                Range("a1").Resize(UBound(arr, 2) + 1, 3) = Application.Transpose(arr)
                wb.SaveAs ThisWorkbook.Path & "\分表\" & "自定义名称-" & k(j) & "-" & m & " " & UBound(arr, 2) + 1
                wb.Close True
        Next
Next
Application.ScreenUpdating = True
Set d = Nothing
Set rs = Nothing
Set cnn = Nothing
End Sub

opiona

1. Sub Opiona()
   
2. 
   
3. 'On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
   
4. Application.ScreenUpdating = False '//关闭屏幕刷新
   
5. Application.DisplayAlerts = False '//关闭系统提示
   
6. t = Timer   '//开始时间
   
7. 
   
8.     PathG = ThisWorkbook.Path & "\分表"
   
9.     Set FSO = CreateObject("Scripting.FileSystemObject")
   
10.     If FSO.FolderExists(PathG) = True Then
    
11.         FSO.GetFolder(PathG).Delete   '//删除文件夹
    
12.     End If
    
13.     Delay 1   '延迟3秒
    
14.     MkDir PathG    '//创建文件夹
    
15.    
    
16.    
    
17.     Set SH1 = Sheets("Sheet1")
    
18. 
    
19.     Str_coon = "HDR=NO';Data Source =" & ThisWorkbook.FullName     '//OFFICE2003，2007 通用
    
20.     StrSQL = "SELECT DISTINCT F2 FROM [" & SH1.Name & "$A:C] WHERE LEN(F2)>0"
    
21.    
    
22.     ARX = GET_SQL_To_Arr(StrSQL, Str_coon, False)
    
23.     For X = 0 To UBound(ARX, 1)
    
24.         StrSQL = "SELECT F1,F2,F3 FROM [" & SH1.Name & "$] WHERE F2='" & ARX(X, 0) & "'"
    
25.         SQLARX = GET_SQL_To_Arr(StrSQL, Str_coon, False)
    
26.         
    
27.         INTG = 1   '记录是此编码的第几个表
    
28.         For I = 0 To UBound(SQLARX, 1) Step 500
    
29.             Set WB = Workbooks.Add
    
30.             Set SHW = WB.Worksheets(1)
    
31.             ReDim ARXX(0 To 499, 0 To 2)
    
32.             
    
33.             MAXROW = 0
    
34.             For Y = 0 To 499
    
35.                 MAXROW = MAXROW + 1  '//记录本表有多少行数据
    
36.                 If I + Y <= UBound(SQLARX, 1) Then
    
37.                     For m = 0 To 2
    
38.                         ARXX(Y, m) = SQLARX(I + Y, m)
    
39.                     Next m
    
40.                 Else
    
41.                     Exit For
    
42.                 End If
    
43.             Next Y
    
44.             SHW.Range("A1").Resize(UBound(ARXX, 1) + 1, UBound(ARXX, 2) + 1) = ARXX
    
45.             WB.SaveAs PathG & "\自定义名称-" & ARX(X, 0) & "-" & Format(INTG, "00") & " " & MAXROW & ".XLSX"
    
46.             WB.Close True
    
47.             INTG = INTG + 1
    
48.         Next I
    
49.     Next X
    
50. 
    
51. Application.ScreenUpdating = True '//恢复屏幕刷新
    
52. Application.DisplayAlerts = True '//恢复系统提示
    
53. MsgBox "一共用时：" & Format(Timer - t, "#0.0000") & " 秒", , "北极狐提示!!"  '//提示所用时间
    
54. End Sub

复制代码

opiona

拆分编程求助.rar (338.35 KB, 下载次数: 36)

2016-7-6 21:28 上传

点击文件名下载附件