文件很大，需按行数拆分为多个excel文件，求指导

zhuzhudaxia

我现在有一个excel表格，共有65536行，9列。需要按每5000行，为一个独立文件，分别拆分出若干个表格文件；

在贵站看了很多老师的，无论怎么换代码，用了后最多都只能拆分出来2个表格(每个5000行)；

所以很无奈，来请求各位老师指导指导；

我这里似乎不用再上传文件了吧？因为行数太多，文件也很大，老师只需要提供一段可行的代码就好啦，再次感谢！！！！

lsc900707

参考10楼代码：
拆分表格，求助
http://club.excelhome.net/thread-1458835-1-1.html
(出处: ExcelHome技术论坛)

zhuzhudaxia

lsc900707 发表于 2019-1-26 18:01
参考10楼代码：
拆分表格，求助
http://club.excelhome.net/thread-1458835-1-1.html

感谢版主老师的热心帮助！！！

BUT我对于代码这方面是零基础。

根据您在另外那个帖子的回复，我目前卡在了这位置（如下所示标红的文字）不知道咋办，因为我是有九列，而您之前回复的那个是只有一列，这个我还不知道怎么套用，请老师指导！！！感谢感谢！

Sub gj23w98()
    Application.ScreenUpdating = False
    With Sheet1
        For i = 2 To .Cells(.Rows.Count, 1).End(3).Row Step 4000
            k = k + 1
            Set wb = Workbooks.Add
            wb.Sheets(1).[a1] = "公司"
            .Rows(i).Resize(4000).Copy wb.Sheets(1).[a2]
            wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k & ".xls"
            wb.Close True
        Next
    End With
    Application.ScreenUpdating = True
End Sub

lsc900707

zhuzhudaxia 发表于 2019-1-28 13:29
感谢版主老师的热心帮助！！！

BUT我对于代码这方面是零基础。

这是标题的问题，那个只有一列的。
上传附件吧，这个容易解决。

zhuzhudaxia

报告版主老师，表格是有14列（捂脸），之前记错了。。。
还有就是，我的表格现在都是xlsx格式，拆分后自动生成的表格文件需要是xls格式的。

附件已上传，请老师指导，感谢了！！！

lsc900707

zhuzhudaxia 发表于 2019-1-28 16:58
报告版主老师，表格是有14列（捂脸），之前记错了。。。
还有就是，我的表格现在都是xlsx格式，拆分后自动 ...

Sub gj23w98()
    Application.ScreenUpdating = False
    With Sheet1
        For i = 2 To .Cells(.Rows.Count, 1).End(3).Row Step 5000
            k = k + 1
            Set wb = Workbooks.Add
             wb.Sheets(1).[a1].Resize(, 14) = .[a1].Resize(, 14).Value
            .Rows(i).Resize(5000, 14).Copy wb.Sheets(1).[a2]
            wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k & ".xls"
            wb.Close True
        Next
    End With
    Application.ScreenUpdating = True
End S

lsc900707

zhuzhudaxia 发表于 2019-1-28 16:58
报告版主老师，表格是有14列（捂脸），之前记错了。。。
还有就是，我的表格现在都是xlsx格式，拆分后自动 ...

参考附件：

hhxq001

lsc900707 发表于 2019-1-28 17:59
Sub gj23w98()
    Application.ScreenUpdating = False
    With Sheet1

好用。。。

ykcbf1100

练习一下。。。

ykcbf1100

练习练习。。。

1. Sub ykcbf()   '//2024.12.8
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     p = ThisWorkbook.Path & ""
   
5.     rr = 500: bt = 1
   
6.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
7.     With sh
   
8.         r = .Cells(Rows.Count, 1).End(3).Row
   
9.         c = .UsedRange.Columns.Count
   
10.     End With
    
11.     numSheets = Int((r - bt) / rr) + 1
    
12.     For i = 1 To numSheets
    
13.         k = k + 1
    
14.         r1 = bt + 1 + (i - 1) * rr
    
15.         r2 = Application.Min(bt + i * rr, r)
    
16.         sh.Copy
    
17.         Set wb = ActiveWorkbook
    
18.         With Sheets(1)
    
19.             .DrawingObjects.Delete
    
20.             .UsedRange.Offset(bt).Clear
    
21.             Set Rng = sh.Range(sh.Cells(r1, 1), sh.Cells(r2, c))
    
22.             Set destRange = .Cells(bt + 1, 1)
    
23.             Rng.Copy Destination:=destRange
    
24.         End With
    
25.         wb.SaveAs Filename:=p & k
    
26.         wb.Close
    
27.     Next
    
28.     Application.ScreenUpdating = True
    
29.     MsgBox "OK！"
    
30. End Sub
    
31. 
    

复制代码