EXCEL总表按照格式拆分成分表

张家卉卉

已得到代码如下，求大神指导拆分后，分表格式与总表统一怎么增加代码！

Sub 分类()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim i%, n%, M%, arr, sht As Worksheet
Dim dc As Object
Set dc = CreateObject("scripting.dictionary")

For Each sht In Worksheets                '清理工作表
   If sht.Name = "项目总表" Then
      GoTo 10
   Else
      sht.Delete
   End If
10:
Next

With Sheets("项目总表")
    i = .Range("a1").End(xlDown).Row
    arr = .Range("a2:n" & i)
End With

For i = 1 To UBound(arr)
  dc(arr(i, 4)) = ""       '选择从哪一列拆分
  'dc(arr(i, 1)) = arr(i, 2)
Next i
M = 2
For Each ke In dc.keys
  Worksheets.Add after:=Worksheets("项目总表")

   With ActiveSheet
     .Name = ke
     .[a1] = "序号": [b1] = " 项目代号": [c1] = " 项目名称"
     For i = 1 To UBound(arr)
        If arr(i, 4) = ke Then
          .Cells(M, 1) = arr(i, 1)             '从这一行开始循环，增加除标题行外其他列
          .Cells(M, 2) = arr(i, 2)
          .Cells(M, 3) = arr(i, 3)
           M = M + 1
           '.Range("a2:b100") = dc(ke).items '.resize(dc(arr(i,1)),2)
        End If

     Next i
   End With
   M = 2
Next

Set dc = Nothing
Erase arr

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

liulang0808

楼主方便的话，就上传附件看看吧

fanyoulin

用复制表，不用增加表，把代码：
   Worksheets.Add after:=Worksheets("项目总表")
改成：
   Worksheets("项目总表").Copy after:=Worksheets(Worksheets.Count)   '复制的表放在最后面
   Worksheets(Worksheets.Count).Cells.ClearContents  '把复制表的内容清除，格式保留

我只是针对你这个问题而写的，没考虑其他因素。如果有错误，相应修改下应该不难。