【VBA】Excel拆分表格，并且复制格式

需求

1、将总表根据【销售部门】拆分成不同的表格

2、拆分后保持格式不变

拆分前

总表

拆分后

表结构

一部

二部

七部

代码如下

Sub cfgzb() '拆分工作表
    Dim i As Integer, endrow As Integer, irow As Integer
    Dim sh As Worksheet
    Dim str As String
    endrow = Sheets("总表").Range("c" & Rows.Count).End(xlUp).Row '找到最后一行的万金油公式
    For i = 3 To endrow
        str = Sheets("总表").Range("c" & i).Value '把部门名称放入字符串str中
        On Error Resume Next '从该语句开始，遇到错误程序不会中止，也不会出现错误提示，将继续运行
        Set sh = Sheets(str) 'sh是工作表
        If Err.Number = 0 Then '如果部门表存在
        irow = sh.Range("a" & Rows.Count).End(xlUp).Row + 1 '保证新复制的数据不会覆盖原有的
        Sheets("总表").Rows(i).Copy sh.Rows(irow)
        Else '如果部门表不存在
            Set sh = Sheets.Add '新建工作表，交给sh
            sh.Name = str '重命名
            sh.Move , Sheets(Sheets.Count) '移动工作表
            Sheets("总表").Rows(1).Copy sh.Rows(1) '按行复制，保留行高
            Sheets("总表").Rows(2).Copy sh.Rows(2)
            Sheets("总表").Rows(i).Copy sh.Rows(3)
            With sh.Cells(3, "a").Resize(1, 8)
                .PasteSpecial xlPasteFormats  '选择性粘贴格式
                .PasteSpecial xlPasteColumnWidths '选择性粘贴列宽
            End With
        End If
        On Error GoTo 0
    Next i
    MsgBox "拆分完成" '全部完成会有一个提示语句
End Sub

 

---

更新版本

---

需求

在第一版的基础上表头出现纵向合并

拆分前

总表

拆分后

一部

二部

七部

代码如下

Sub cfgzb() '拆分工作表
    Dim i As Integer, endrow As Integer, irow As Integer
    Dim sh As Worksheet
    Dim str As String
    endrow = Sheets("总表").Range("c" & Rows.Count).End(xlUp).Row '找到最后一行的万金油公式
    For i = 5 To endrow
        str = Sheets("总表").Range("c" & i).Value '把部门名称放入字符串str中
        On Error Resume Next '从该语句开始，遇到错误程序不会中止，也不会出现错误提示，将继续运行
        Set sh = Sheets(str) 'sh是工作表
        If Err.Number = 0 Then '如果部门表存在
        irow = sh.Range("a" & Rows.Count).End(xlUp).Row + 1 '保证新复制的数据不会覆盖原有的
        Sheets("总表").Rows(i).Copy sh.Rows(irow)
        Else '如果部门表不存在
            Set sh = Sheets.Add '新建工作表，交给sh
            sh.Name = str '重命名
            sh.Move , Sheets(Sheets.Count) '移动工作表
            Sheets("总表").Range("A1:H3").Copy sh.Range("A1:H3")
            Sheets("总表").Rows(4).Copy sh.Rows(4) '按行复制，保留行高
            Sheets("总表").Rows(i).Copy sh.Rows(5)
            With sh.Cells(5, "a").Resize(1, 8)
                .PasteSpecial xlPasteFormats  '选择性粘贴格式
                .PasteSpecial xlPasteColumnWidths '选择性粘贴列宽
            End With
        End If
        On Error GoTo 0
    Next i
    MsgBox "拆分完成" '全部完成会有一个提示语句
End Sub