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

我为丑陋的代码道歉，我正在通过谷歌自己学习这门语言，所以你在这里看到的是弗兰肯斯坦，我发现其他一些事情，我已经稍微调整了一些工作。正如我所说，它按原样运行，但我真的很喜欢它更高效，因为数千行数据需要10分钟，而且手动分割纸张的效率会降低。

Answer 1

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

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

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

1 个答案: