Excel-Tabellen über VBA teilen und speichern

Question

Ich versuche, ein Makro für Excel zu schreiben, das Daten in irgendeiner Anzahl von Spalten nimmt und es in eine spezifizierte Anzahl von Zeilen pro Blatt aufteilt, mit einer separaten Eingabeaufforderung, die fragt, ob ich würde gerne die Blätter als separate Dateien sichern. Was ich geschrieben habe funktioniert, aber es ist schmerzhaft ineffizient für mehr als ein paar hundert Zeilen. Könnte mir bitte jemand ein paar Hinweise geben?

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 

ich für den hässlichen Code entschuldigen, ich bin die Sprache auf meiner eigenen über Google zu lernen, so, was Sie hier sehen, ist ein Frankenstein von einigen anderen Dingen, die ich gefunden habe, dass ich etwas gezwickt habe zu machen Arbeit. Wie gesagt, es funktioniert so wie es ist, aber ich würde es wirklich lieben, effizienter zu sein, da es für Tausende von Datenzeilen 10 Minuten dauert und weniger effizient ist, als die Blätter manuell zu teilen.

Answer 1

Ich füge die neuen Arbeitsblätter zu einem neuen Arbeitsbuch hinzu. Ich benutzte ein Array, um es super schnell zu machen, aber es kopiert nicht die Formatierung. Brauchst du es formatiert?

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