Excel vba怎样做可以每两百行分割成一个新的Excel

请问大家，Excel 利用vba怎样做可以每两百行分割成一份新的Excel

你可以使用以下VBA代码将每两百行分割成一份新的Excel文件：

vba

Sub SplitExcel()  
    Dim i As Integer  
    Dim lastRow As Long  
    Dim currentRow As Long  
    Dim newWorkbook As Workbook  
    Dim currentWorkbook As Workbook  
      
    Set currentWorkbook = ActiveWorkbook '设置当前工作簿  
    lastRow = currentWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row '获取当前工作表的最后一行  
      
    For i = 2 To lastRow Step 200 '循环分割每200行  
        Set newWorkbook = Workbooks.Add '新建一个工作簿  
        currentWorkbook.Sheets(1).Range("A" & i & ":A" & i + 199).Copy '复制当前工作表中的200行数据  
        newWorkbook.Sheets(1).Range("A1").PasteSpecial xlPasteValues '粘贴到新工作表中，只保留值  
        newWorkbook.SaveAs "C:\example\newworkbook" & i & ".xlsx", FileFormat:=xlOpenXMLWorkbook '保存为新文件  
        newWorkbook.Close SaveChanges:=False '关闭新工作簿  
    Next i  
      
    MsgBox "分割完成！" '提示分割完成  
End Sub

请确保修改代码中的“C:\example\newworkbook”为您想要保存新文件的路径。此外，您可以根据需要更改文件名和路径。运行此代码后，它将创建一系列新文件，每个文件包含200行数据。

菩薩慈悲：試試看我以下的程式碼吧。感恩感恩　南無阿彌陀佛

Sub SplitData_Excel_vba_how_to_do_can_every_two_hundred_rows_split_into_a_new_Excel()
    Dim fso As Object 'New FileSystemObject
    Dim wb As Workbook, ws As Worksheet, newFileName As String, extension As String, wbName As String
    Dim path As String, lastColumn As Long, i As Long
    Dim sheetCounter As Long
    Set fso = CreateObject("scripting.FileSystemObject")
    Set wb = ActiveWorkbook: Set ws = wb.ActiveSheet
    path = wb.path
    path = fso.CreateFolder(path + "\" + "SplitData_Excel_vba_how_to_do_can_every_two_hundred_rows_split_into_a_new_Excel").path
    
    wbName = wb.Name: extension = "." + Right(wbName, Len(wbName) - InStrRev(wbName, ".", , 1))
        
    Dim lastRow As Long
    Dim rowCounter As Long, rowStart As Long
    Dim newWorkbook As Workbook
    Dim newWorksheet As Worksheet
    
    lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    'lastRow = ws.UsedRange.Rows.Count
    lastColumn = ws.UsedRange.Columns.Count
    
    rowCounter = 0
    
    Excel.Application.ScreenUpdating = False
    Rem 若無欄名，則下行請用： For i = 1 To lastRow
    For i = 2 To lastRow
        If rowStart = 0 Then rowStart = i
        rowCounter = rowCounter + 1
        If rowCounter = 200 Then
lastPart:
            sheetCounter = sheetCounter + 1
            Set newWorkbook = Workbooks.Add() '(wb.ContentTypeProperties("Template"))
'            newWorkbook.Windows(1).Visible = False
            Set newWorksheet = newWorkbook.Sheets(1)
            Range(ws.Cells(rowStart, 1), ws.Cells(i, lastColumn)).Copy _
                Destination:=newWorksheet.Range(newWorksheet.Cells(1, 1), newWorksheet.Cells(rowCounter, lastColumn))
            'newFileName = Left(wbName, InStr(wbName, extension) - 1) & sheetCounter & extension
            newFileName = Left(wbName, InStr(wbName, extension) - 1) & sheetCounter & ".xlsx"
            With newWorkbook
                '.SaveCopyAs path + "\" + newFileName
'                newWorkbook.Windows(1).Visible = True
                .SaveAs path + "\" + newFileName
                .Close
            End With
            rowCounter = 0: rowStart = 0
        End If
    Next i
    
    If rowCounter > 0 And rowCounter < 200 Then
        i = lastRow
        GoTo lastPart
    End If
    Excel.Application.ScreenUpdating = True
    MsgBox "done!", vbInformation
End Sub

参考：https://blog.csdn.net/hhhhh_51/article/details/123192902