Private Sub btnSplit_Click()Dim StartRow As Long, KeyCol As StringStartRow = CLng(Trim(Me.cbStart.Text))KeyCol = Trim(Me.cbKey.Text)DelCol = Trim(Me.cbDel.Text)indexCol = Trim(Me.cbIndex.Text)If DelCol <> "" Thendel = Range(DelCol & "1").ColumnElsedel = 0End Ifmethod = Me.cbMethod.TextSelect Case methodCase "单簿多表" , "多簿单表"Splitsheet ActiveSheet, StartRow, Range(KeyCol & "1").Column, 1, del, indexColCase ElseMsgBox "拆分方式错误！"End Select
End Sub
Private Sub UserForm_Initialize()With Me.cbMethod.Clear.AddItem "单簿多表".AddItem "多簿单表".Text = "单簿多表"End WithWith Me.cbKey.ClearFor I = 1 To 26.AddItem Split(ActiveSheet.Cells(1, I).Address(1, 0), "$")(0)Next I.Text = "A"End WithWith Me.cbDel.ClearFor I = 1 To 26.AddItem Split(ActiveSheet.Cells(1, I).Address(1, 0), "$")(0)Next IEnd WithWith Me.cbIndex.ClearFor I = 1 To 26.AddItem Split(ActiveSheet.Cells(1, I).Address(1, 0), "$")(0)Next IEnd WithWith Me.cbStart.ClearFor I = 1 To 10.AddItem INext I.Text = "2"End With
End Sub

Public Sub showfrm()UserForm1.Show
End SubSub Splitsheet(ByVal sht As Worksheet, ByVal StartRow As Long, ByVal KeyColumn As Long, ByVal method As Long, ByVal DelCol As Long, ByVal indexCol As String)Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseSet wb = Application.ThisWorkbookFolderPath = wb.Path & "\"Set dic = CreateObject("Scripting.Dictionary")With shtEndRow = .Cells(.Cells.Rows.Count, KeyColumn).End(xlUp).RowFor I = StartRow To EndRowKey = .Cells(I, KeyColumn).ValueIf Key <> "" Then dic(Key) = ""Next IEnd WithIf method = 1 ThenFor Each onekey In dic.keysSet desSheet = wb.Worksheets(wb.Worksheets.Count)CopySheetAndRetainRows sht, desSheet, StartRow, KeyColumn, onekey, DelCol, indexColNext onekeyElseFor Each onekey In dic.keysFilename = onekey & ".xlsx"FilePath = FolderPath & FilenameOn Error Resume NextKill FilePathOn Error GoTo 0Set newwb = Application.Workbooks.Addnewwb.SaveAs FilePathSet desSheet = newwb.Worksheets(1)CopySheetAndRetainRows sht, desSheet, StartRow, KeyColumn, onekey, DelCol, indexColNext onekeyEnd IfApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueMsgBox "拆分结束"Unload UserForm1
End SubSub CopySheetAndRetainRows(ByVal scrSheet As Worksheet, ByVal desSheet As Worksheet, ByVal StartRow As Long, ByVal KeyColumn As Long, ByVal Retain As String, ByVal DelCol As Long, ByVal indexCol As String)Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseDim wb As WorkbookDim newSheet As Worksheet, Rng As RangeDim RetainStart, RetainEndscrSheet.Copy after:=desSheetSet wb = desSheet.ParentFor Each onesht In wb.WorksheetsIf onesht.Name = Retain Then onesht.DeleteNext oneshtSet newSheet = wb.Worksheets(wb.Worksheets.Count)newSheet.Name = RetainWith newSheetEndRow = .Cells(.Cells.Rows.Count, KeyColumn).End(xlUp).RowFor I = StartRow To EndRowIf .Cells(I, KeyColumn).Value = Retain ThenIf RetainStart = 0 Then RetainStart = IRetainEnd = IEnd IfNext IIf RetainEnd < EndRow ThenSet Rng = .Rows(RetainEnd + 1 & ":" & EndRow)Rng.Delete Shift:=xlUpEnd IfSet Rng = NothingIf RetainStart > StartRow ThenSet Rng = .Rows(StartRow & ":" & RetainStart - 1)Rng.Delete Shift:=xlUpEnd IfSet Rng = NothingIf indexCol <> "" ThenX = 1For I = StartRow To StartRow + RetainEnd - RetainStart + 1.Cells(I, indexCol).Value = XX = X + 1Next IEnd IfIf DelCol <> 0 Then .Columns(DelCol).DeleteEnd WithIf ThisWorkbook.Name <> wb.Name Thenwb.Worksheets(1).Deletewb.Close TrueEnd IfApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueEnd Sub