将汇总表按标准模板拆分

adminsong

想实现的功能：1.当汇总表中的内容填写完后，点击按钮将汇总表中的内容按照模板的格式一一的拆分写入不同表格，拆分时根据合格证编号分类，合格证编号相同的写入同一个表格；2.表格名称根据合格证编号或者工程名称命名；

lsc900707

需要一些时间处理>>>>>>>>>>>>

liulang0808

Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For J = 2 To UBound(arr)
        If d.exists(arr(J, 1) & "##" & arr(J, 2) & "##" & arr(J, 3)) Then
            Set d(arr(J, 1) & "##" & arr(J, 2) & "##" & arr(J, 3)) = Union(Cells(J, 4).Resize(1, 11), d(arr(J, 1) & "##" & arr(J, 2) & "##" & arr(J, 3)))
        Else
            Set d(arr(J, 1) & "##" & arr(J, 2) & "##" & arr(J, 3)) = Cells(J, 4).Resize(1, 11)
        End If
    Next J
    For J = 0 To d.Count - 1
        Sheets(2).Copy after:=Sheets(2)
        arr = Split(d.keys()(J), "##")
        Sheets(3).Name = d.keys()(J)
        Sheets(3).Cells(4, 3) = arr(1)
        Sheets(3).Cells(3, "k") = arr(0)
        Sheets(3).Cells(4, "j") = arr(2)
        d.items()(J).Copy Sheets(3).[b7]
    Next J
    Application.ScreenUpdating = True
End Sub

liulang0808

具体见附件内容，，，，，

adminsong

liulang0808 发表于 2016-9-9 18:27
具体见附件内容，，，，，

谢谢版主，符合我的要求，能减少我不少工作量，还有一个问题，就是能不能把日期写在左下角的日期表格内

adminsong

能否把日期写在左下角红色区域

lsc900707

adminsong 发表于 2016-9-10 10:33
能否把日期写在左下角红色区域

直径这一列变成日期了，你没检查出来？

adminsong

lsc900707 发表于 2016-9-10 10:38
直径这一列变成日期了，你没检查出来？

看到了，我是想把直径位置的数据改成需要的，日期写在单独的位置，

liulang0808

adminsong 发表于 2016-9-10 10:28
谢谢版主，符合我的要求，能减少我不少工作量，还有一个问题，就是能不能把日期写在左下角的日期表格内

楼主可以根据需要自行调整看看吧

adminsong

liulang0808 发表于 2016-9-10 23:20
楼主可以根据需要自行调整看看吧

谢谢您的回复，我按照您的模板自己改了一下，时间可以放在指定的位置，就是有个问题，按照之前的表格命名规则的话提示错位，我现在只能是按照页数命名新表，能不能麻烦您再给修改下代码，拆分后的新表按照工程名称和编号命名，新生成的模板表格中有一个表格会自动带拆分的按钮，能否给取消掉？这是我改后的代码

1. Sub 按钮1_Click()
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = [a1].CurrentRegion
   
5.     For j = 2 To UBound(arr)
   
6.         If d.exists(arr(j, 1) & "##" & arr(j, 2) & "##" & arr(j, 3) & "##" & arr(j, 4)) Then
   
7.             Set d(arr(j, 1) & "##" & arr(j, 2) & "##" & arr(j, 3) & "##" & arr(j, 4)) = Union(Cells(j, 5).Resize(1, 10), d(arr(j, 1) & "##" & arr(j, 2) & "##" & arr(j, 3) & "##" & arr(j, 4)))
   
8.         Else
   
9.             Set d(arr(j, 1) & "##" & arr(j, 2) & "##" & arr(j, 3) & "##" & arr(j, 4)) = Cells(j, 5).Resize(1, 10)
   
10.         End If
    
11.     Next j
    
12.     For j = 0 To d.Count - 1
    
13.         Sheets(2).Copy after:=Sheets(2)
    
14.         arr = Split(d.keys()(j), "##")
    
15.         Sheets(3).Name = "第" & (j) & "页"
    
16.         Sheets(3).Cells(4, 3) = arr(1)
    
17.         Sheets(3).Cells(3, "k") = arr(0)
    
18.         Sheets(3).Cells(4, "j") = arr(2)
    
19.         Sheets(3).Cells(19, "b") = arr(3)
    
20.         d.items()(j).Copy Sheets(3).[b7]
    
21.     Next j
    
22.     Application.ScreenUpdating = True
    
23. End Sub
    

复制代码