通过VBA分割和保存Excel电子表格

我试图写一个Excel的macros，它将采取任意数量的列中的数据，并将其分割成每张表中指定数量的行，并提供一个单独的提示，询问是否要将表单作为单独的文件备份。 我写的作品，但是对于任何超过几百行的行为来说，效率是非常低的。 有人能给我一些指点吗？

Private Sub ButtonOK_Click() ' Make sure the UserForm is completely filled in If OptionYES.Value = False And OptionNO.Value = False Then MsgBox ("Please select if there is a header or not.") Exit Sub End If If TextNUMROWS.Value = "" Then MsgBox ("Please enter the number of cells you would like in each sheet.") Exit Sub End If If ComboBoxFileType.ListIndex = -1 Then MsgBox ("Please select if you would like backup files of the sheets to be created.") Exit Sub End If Dim SheetName As String Dim FinalRow As Double, NumSheets As Double Dim NextSheet As Integer SheetName = ActiveSheet.Name If OptionNO.Value = True Then NextSheet = TextNUMROWS - 1 Else NextSheet = TextNUMROWS End If ' Get "Header?" value If OptionYES.Value = True Then FinalRow = Cells(Rows.Count, 1).End(xlUp).Row - 1 Else FinalRow = Cells(Rows.Count, 1).End(xlUp).Row End If NumSheets = WorksheetFunction.Ceiling(FinalRow / TextNUMROWS, 1) If NumSheets > 20 Then MsgBox ("The number of subsheets exceeds 20. Please reconfigure your data.") Exit Sub End If ' Create new sheets with/without headers For Iter1 = 1 To NumSheets Sheets.Add.Name = SheetName & "_sp" & Iter1 If OptionYES.Value = True Then Worksheets(SheetName).Rows(1).EntireRow.Copy With Sheets(SheetName & "_sp" & Iter1) .Range("A" & .UsedRange.Rows.Count).PasteSpecial End With End If Next Iter1 ' Copy and paste data to newly created sheets For Iter2 = 1 To NumSheets If OptionNO.Value = True Then Worksheets(SheetName).Rows(((Iter2 - 1) * TextNUMROWS) + 1).EntireRow.Copy With Sheets(SheetName & "_sp" & Iter2) .Range("A1").PasteSpecial End With End If For Iter3 = 1 To NextSheet Worksheets(SheetName).Rows(((Iter2 - 1) * TextNUMROWS) + Iter3 + 1).EntireRow.Copy With Sheets(SheetName & "_sp" & Iter2) .Range("A" & .UsedRange.Rows.Count + 1).PasteSpecial End With Next Iter3 Sheets(SheetName & "_sp" & Iter2).Activate ActiveSheet.Cells(1, 1).Select Next Iter2 'Sort lists alphabetically Dim N As Integer Dim M As Integer Dim FirstWSToSort As Integer Dim LastWSToSort As Integer Dim SortDescending As Boolean SortDescending = False If ActiveWindow.SelectedSheets.Count = 1 Then 'Change the 1 to the worksheet you want sorted first FirstWSToSort = 1 LastWSToSort = Worksheets.Count Else With ActiveWindow.SelectedSheets For N = 2 To .Count If .Item(N - 1).Index <> .Item(N).Index - 1 Then MsgBox "You cannot sort non-adjacent sheets" Exit Sub End If Next N FirstWSToSort = .Item(1).Index LastWSToSort = .Item(.Count).Index End With End If For M = FirstWSToSort To LastWSToSort For N = M To LastWSToSort If SortDescending = True Then If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then Worksheets(N).Move Before:=Worksheets(M) End If Else If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then Worksheets(N).Move Before:=Worksheets(M) End If End If Next N Next M 'Create sheet backup files Select Case ComboBoxFileType.ListIndex Case Is = 0 FileType = ".xlsx" Case Is = 1 FileType = ".xls" Case Is = 2 FileType = ".csv" End Select If ComboBoxFileType.ListIndex <> 3 Then Dim xPath As String xPath = Application.ActiveWorkbook.Path Application.ScreenUpdating = False Application.DisplayAlerts = False For Each xWs In ThisWorkbook.Sheets xWs.Copy Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & FileType Application.ActiveWorkbook.Close False Next Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox ("Done. Data has been split into " & NumSheets & " sheets and saved as file type " & FileType & ".") Else MsgBox ("Done. Data has been split into " & NumSheets & " sheets.") End If Unload Me End Sub Private Sub ButtonCANCEL_Click() Unload Me End Sub Private Sub UserForm_Initialize() With Me.ComboBoxFileType .AddItem "Yes, save as .xlsx." .AddItem "Yes, save as .xls." .AddItem "Yes, save as .csv." .AddItem "No, do not save sheets." End With End Sub 

我为那些丑陋的代码道歉，我正在通过Google学习这门语言，所以你在这里看到的是一些科学怪人，我发现我已经微调了一些其他的东西来做工作。 正如我所说的那样，它的工作原理是这样的，但是我真的很喜欢它，因为它需要数十万分钟的时间来处理数千行数据，并且效率比手动分割纸张要低。

Answer 1

我将新的WorkSheet添加到一个新的工作簿。 我使用了一个数组来使其超快，但它不会复制格式。 你需要格式化吗？

 Option Explicit Sub SplitWorkSheet() Const ROWCOUNT = 10 Dim xlWB As Workbook, xlWS As Worksheet Dim arrData Dim i As Long, j As Long, k As Integer, rows As Long, cols As Integer Application.ScreenUpdating = False Application.Calculation = xlCalculationManual arrData = ActiveSheet.Range("a1").CurrentRegion.Value If IsEmpty(arrData) Then Exit Sub rows = UBound(arrData, 1) cols = UBound(arrData, 2) Application.SheetsInNewWorkbook = Application.WorksheetFunction.RoundUp(rows / ROWCOUNT, 0) Set xlWB = Application.Workbooks.Add Application.SheetsInNewWorkbook = 3 Set xlWS = xlWB.ActiveSheet For i = 1 To rows k = k + 1 For j = 1 To cols xlWS.Cells(k, j) = arrData(i, j) Next j If i = rows Then ElseIf k = 10 Then k = 0 Set xlWS = xlWB.Worksheets(xlWS.Index + 1) End If Next Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub