如何保持格式拆分工作表？

Posted 2021-10-28 nextseven

在拆分的时候如何保持单元格的格式不变呢？我能想到的办法就是复制和移动工作表，然后再把不符合条件的行删除。

窗体代码

Private Sub btnSplit_Click()
    Dim StartRow As Long, KeyCol As String
    StartRow = CLng(Trim(Me.cbStart.Text))
    KeyCol = Trim(Me.cbKey.Text)
    DelCol = Trim(Me.cbDel.Text)
    indexCol = Trim(Me.cbIndex.Text)
    
    If DelCol <> "" Then
        del = Range(DelCol & "1").Column
    Else
        del = 0
    End If
    
    
    method = Me.cbMethod.Text
    Select Case method
    Case "单簿多表" , "多簿单表"
        Splitsheet ActiveSheet, StartRow, Range(KeyCol & "1").Column, 1, del, indexCol
    Case Else
        MsgBox "拆分方式错误！"
    End Select
End Sub
Private Sub UserForm_Initialize()
    With Me.cbMethod
        .Clear
        .AddItem "单簿多表"
        .AddItem "多簿单表"
        .Text = "单簿多表"
    End With
    With Me.cbKey
        .Clear
        For I = 1 To 26
            .AddItem Split(ActiveSheet.Cells(1, I).Address(1, 0), "$")(0)
        Next I
        .Text = "A"
    End With
    
    With Me.cbDel
        .Clear
        For I = 1 To 26
            .AddItem Split(ActiveSheet.Cells(1, I).Address(1, 0), "$")(0)
        Next I
    End With
    
    With Me.cbIndex
        .Clear
        For I = 1 To 26
            .AddItem Split(ActiveSheet.Cells(1, I).Address(1, 0), "$")(0)
        Next I
    End With
    
    With Me.cbStart
        .Clear
        For I = 1 To 10
            .AddItem I
        Next I
        .Text = "2"
    End With
End Sub

　

模块代码

Public Sub showfrm()
    UserForm1.Show
End Sub

Sub 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 = False
    Application.DisplayAlerts = False
    
    Set wb = Application.ThisWorkbook
    FolderPath = wb.Path & "\\"
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    With sht
        EndRow = .Cells(.Cells.Rows.Count, KeyColumn).End(xlUp).Row
        For I = StartRow To EndRow
            Key = .Cells(I, KeyColumn).Value
            If Key <> "" Then dic(Key) = ""
        Next I
    End With
    
    If method = 1 Then
        For Each onekey In dic.keys
            Set desSheet = wb.Worksheets(wb.Worksheets.Count)
            CopySheetAndRetainRows sht, desSheet, StartRow, KeyColumn, onekey, DelCol, indexCol
        Next onekey
    Else
        
        
        
        For Each onekey In dic.keys
            Filename = onekey & ".xlsx"
            FilePath = FolderPath & Filename
            On Error Resume Next
            Kill FilePath
            On Error GoTo 0
            Set newwb = Application.Workbooks.Add
            newwb.SaveAs FilePath
            
            Set desSheet = newwb.Worksheets(1)
            CopySheetAndRetainRows sht, desSheet, StartRow, KeyColumn, onekey, DelCol, indexCol
        Next onekey
        
        
        
    End If
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "拆分结束"
    Unload UserForm1
End Sub


Sub 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 = False
    Application.DisplayAlerts = False
    
    Dim wb As Workbook
    Dim newSheet As Worksheet, Rng As Range
    Dim RetainStart, RetainEnd
    scrSheet.Copy after:=desSheet
    Set wb = desSheet.Parent
    For Each onesht In wb.Worksheets
        If onesht.Name = Retain Then onesht.Delete
    Next onesht
    Set newSheet = wb.Worksheets(wb.Worksheets.Count)
    newSheet.Name = Retain
    With newSheet
        
        EndRow = .Cells(.Cells.Rows.Count, KeyColumn).End(xlUp).Row
        
        For I = StartRow To EndRow
            If .Cells(I, KeyColumn).Value = Retain Then
                If RetainStart = 0 Then RetainStart = I
                RetainEnd = I
            End If
        Next I
        
        
                
        If RetainEnd < EndRow Then
            Set Rng = .Rows(RetainEnd + 1 & ":" & EndRow)
            Rng.Delete Shift:=xlUp
        End If
        Set Rng = Nothing
        
        If RetainStart > StartRow Then
            Set Rng = .Rows(StartRow & ":" & RetainStart - 1)
            Rng.Delete Shift:=xlUp
        End If
        Set Rng = Nothing
        If indexCol <> "" Then
        X = 1
        For I = StartRow To StartRow + RetainEnd - RetainStart + 1
            .Cells(I, indexCol).Value = X
            X = X + 1
        Next I
        
        End If
        If DelCol <> 0 Then .Columns(DelCol).Delete
        
    End With
    
    If ThisWorkbook.Name <> wb.Name Then
        wb.Worksheets(1).Delete
        wb.Close True
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub