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

Question

我正在尝试为Excel编写一个宏，它将采用任意数量的列中的数据并将其拆分为每张表中的指定行数，并提供单独的提示，询问我是否喜欢将表单作为单独的文件备份。我写的作品，但对于几百行以上的作品而言，效率并不高。有人能给我一些指点吗？

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 

我的丑陋的代码道歉，我在学习上我自己通过谷歌的语言，所以你在这里看到的是我发现，我已经调整了稍微做一些其他的事情一个怪人工作。正如我所说的那样，它现在可以正常工作，但我真的很喜欢它，因为它需要数十分钟的时间处理数千行数据，并且效率低于手动分割纸张。

Answer 1

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

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