如何将excel表中的数据每500行分成一个表

求学excel大师

一个excel表中有几万条数据，需要每500个行分成一个excel表，求大师指点。

shiruiqiang

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, i&, wks As Worksheet
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
     
    ar = [A1].CurrentRegion.Value
    ar = cutArray(ar, 500)
    With Workbooks.Add
        For i = 1 To UBound(ar)
            With .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
                .Name = i
                .[A1].Resize(UBound(ar(i)), UBound(ar(i), 2)) = ar(i)
            End With
        Next i
        For Each wks In .Worksheets
            If wks.Name Like "*Sheet*" Then wks.Delete
        Next
    End With
   
    Application.DisplayAlerts = False
    Application.ScreenUpdating = True
    Beep
End Sub
Function cutArray(ByVal ar, ByVal iCutNum&) As Variant()
    Dim br(), cr(), i&, j&, iPosRow&, r&, k&
   
    For i = 1 To UBound(ar) Step iCutNum
        iPosRow = IIf((i + iCutNum - 1) > UBound(ar), _
        UBound(ar) Mod iCutNum, iCutNum)
        
        ReDim cr(1 To iPosRow, 1 To UBound(ar, 2))
        For j = 1 To UBound(cr)
            For k = 1 To UBound(cr, 2)
                cr(j, k) = ar(i - 1 + j, k)
            Next k
        Next j
        r = r + 1
        ReDim Preserve br(1 To r)
        br(r) = cr
    Next i
    cutArray = br
End Function

gwjkkkkk

请参考。。。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.11.12
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
5.     For Each sht In Sheets
   
6.         If sht.Name <> sh.Name Then sht.Delete
   
7.     Next
   
8.     With sh
   
9.         r = .Cells(Rows.Count, 1).End(3).Row
   
10.         rr = 500
    
11.         k = r \ rr + 1
    
12.         For x = 1 To k
    
13.             r1 = (x - 1) * rr + 1
    
14.             If x = k Then r2 = r Else r2 = rr * x
    
15.             Sheets.Add(After:=Sheets(Sheets.Count)).Name = CStr(x)
    
16.             sh.Rows(r1 & ":" & r2).Copy Sheets(CStr(x)).[a1]
    
17.             Sheets(CStr(x)).DrawingObjects.Delete
    
18.         Next
    
19.     End With
    
20.     sh.Activate
    
21.     Application.ScreenUpdating = True
    
22.     MsgBox "OK！"
    
23. End Sub
    

复制代码

limonet

你这个模拟一点都不认真。

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet1")
    arr = sht.[a1].CurrentRegion
    For i = 1 To UBound(arr) Step 500
        n = n + 1
        Set ws = Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count))
        ws.Name = n
        sht.[a1].Offset((n - 1) * 500).Resize(500, UBound(arr, 2)).Copy ws.[a1]
    Next
    Beep
End Sub

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, Rst As Object, i%
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    Set Rst = Cn.Execute("Select * From [Sheet1$]")
    Do Until Rst.EOF
        i = i + 1
        Arr = Rst.GetRows(500)
        Workbooks.Add
        ActiveSheet.Range("A1:B1") = Array("序号", "模拟")
        Range("A2").Resize(500, UBound(Arr) + 1) = Application.Transpose(Arr)
        ActiveWorkbook.Close True, ThisWorkbook.Path & "\" & i * 500 & ".xlsx"
    Loop
End Sub