通過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