zoukankan      html  css  js  c++  java
  • 如何保持格式拆分工作表?

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

    窗体代码

    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
    

      

     

  • 相关阅读:
    JS 逻辑运算符&&与||的运算
    Jquery on("click") 方法绑定事件后执行多次解决办法
    java的web开发使用struts2/springMVC和spring框架理解
    HTTPClient
    eclipse中配置tomcat内存大小
    杀掉window占用端口
    Unirest
    乐观锁
    自定义标签
    xss和csrf攻击
  • 原文地址:https://www.cnblogs.com/nextseven/p/10777162.html
Copyright © 2011-2022 走看看