社保按公司自动分表

caicl

总表里是已经整理好的各家公司在A公司购买社保的名单，想通过宏代码自动按公司按级别分表，具体要求如下：1、按公司分开成表。
2、每个公司分高管及非高管两个表，高管指级别里为A级及B级的，其他级别均为非高管。
3、分出来的表格按一级部门分类汇总。
4、分出来的工作表按“公司代码－高管”，“公司代码－非高管”命名。
5、分出来的工作表标题按总表中的：“2018年8月A公司购买社保清单”按分类自动更新成“2018年8月某公司在A公司购买社保清单-非高管/高管”，某公司可以取总表中的所属公司此列数据。
6、所有的表生成均在原表中。
7、生成效果、格式及模板见附件。

caicl

请问有没有哪位大神帮帮忙？

xyxcc177

要求太多，会把人吓跑的

魂断蓝桥

Sub a()
Dim sh As Worksheet
Application.DisplayAlerts = False
For Each sh In Sheets
    If sh.Name <> "总表" Then
        sh.Delete
    End If
Next
Dim cnn As Object
Dim Sql As String, arr, i%, rs, BT, DBT, R%
BT = Array("序号", "一级部门", "二级部门", "工号", "姓名", "入职日期", "级别", "缴费基数", "公司缴费", "个人缴费", "合计缴费")
DBT = Array("制表：", "", "", "", "审核：", "", "", "", "审批：")
Set cnn = CreateObject("ADODB.CONNECTION")
Set rs = CreateObject("adodb.Recordset")
cnn.Open "Provider=Microsoft.ACE.OleDb.12.0;Extended Properties='Excel 12.0;HDR=YES'; Data Source=" & ThisWorkbook.FullName
Sql = "select distinct 所属公司 from [总表$p2:p] where 所属公司 is not null"
arr = cnn.Execute(Sql).getrows
For i = 0 To UBound(arr, 2)
    Sql = "select 一级部门,二级部门,工号,姓名,入职日期,级别,缴费基数,公司缴费,个人缴费,合计缴费 from [总表$B2:p] " _
            & "where 所属公司='" & arr(0, i) & "' AND 级别 IN ('A级','B级')"
        rs.Open Sql, cnn, 1, 1
            If rs.RecordCount > 0 Then
                Sheets.Add AFTER:=Sheets(Sheets.Count)
                 ActiveSheet.Name = arr(0, i) & "-高管"
                 ActiveSheet.[A1] = Replace(Sheet1.[A1], "购买社保清单", "") & "在" & arr(0, i) & "公司购买社保清单_高管"
                GoSub 100
                rs.Close
            End If
            Sql = "select 一级部门,二级部门,工号,姓名,入职日期,级别,缴费基数,公司缴费,个人缴费,合计缴费 from [总表$B2:p] " _
            & "where 所属公司='" & arr(0, i) & "' AND 级别 not IN ('A级','B级')"
            If rs.State = 1 Then rs.Close
        rs.Open Sql, cnn, 1, 1
            If rs.RecordCount > 0 Then
                Sheets.Add AFTER:=Sheets(Sheets.Count)
                ActiveSheet.Name = arr(0, i) & "-非高管"
                 ActiveSheet.[A1] = Replace(Sheet1.[A1], "购买社保清单", "") & "在" & arr(0, i) & "公司购买社保清单_非高管"
                GoSub 100
                rs.Close
            End If
Next
cnn.Close: Set cnn = Nothing
Exit Sub
100:
                    With ActiveSheet
                        .[A2].Resize(1, 11) = BT
                        .[a3] = 1
                        .Range("A3").AutoFill Destination:=Range("A3").Resize(rs.RecordCount), Type:=xlFillSeries
                        .[B3].CopyFromRecordset rs
                        .[A2].CurrentRegion.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(9, 10, 11) _
        , Replace:=True, SummaryBelowData:=True
                        .Range("A1:K1").Merge
                        .Cells.HorizontalAlignment = xlCenter
                        .Cells.VerticalAlignment = xlCenter
                        R = .[B9999].End(3).Row
                        .Range("a2:k" & R).Borders.LineStyle = 1
                        .[A1].Offset(R + 1, 0).Resize(1, 9) = DBT
                         .Columns("A:k").EntireColumn.AutoFit
                         .Cells.Font.Name = "微软雅黑"
                        .Cells.Font.Size = 10
                    End With
                    Return
End Sub

魂断蓝桥

代码审核中，先上附件吧

社保购买模板.rar (31.42 KB, 下载次数: 20)

2018-8-8 15:48 上传

点击文件名下载附件

caicl

魂断蓝桥 发表于 2018-8-8 15:48
代码审核中，先上附件吧

感谢！但目前发现还有个别问题：
1、拆分出去的表格标题下面会多出一个一级部门汇总，这行能删除吗？
2、另外我把数据更新后，发现数据所属公司如果出现第二个公司时，运行宏时会出现：“运行时错误：1004，类Range的AutoFill方法无效”，请问这是什么原因？
3、拆分的工作表打印格式能不能用我附件上的？
以上，能否再帮忙看下？谢谢！

caicl

魂断蓝桥 发表于 2018-8-8 15:48
代码审核中，先上附件吧

好像是这个宏代码中如果第二个公司有高管的话就不能运行。

魂断蓝桥

caicl 发表于 2018-8-8 18:03
好像是这个宏代码中如果第二个公司有高管的话就不能运行。

1、2
用此代码

3、拆分的工作表打印格式能不能用我附件上的？ 这个你需要什么格式？这个已经按照你的附件格式填写了。还需要调整哪个地方？

Option Explicit

Sub a()
Dim sh As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each sh In Sheets
    If sh.Name <> "总表" Then
        sh.Delete
    End If
Next
Dim cnn As Object
Dim Sql As String, arr, i%, rs, BT, DBT, R%
BT = Array("序号", "一级部门", "二级部门", "工号", "姓名", "入职日期", "级别", "缴费基数", "公司缴费", "个人缴费", "合计缴费")
DBT = Array("制表：", "", "", "", "审核：", "", "", "", "审批：")
Set cnn = CreateObject("ADODB.CONNECTION")
Set rs = CreateObject("adodb.Recordset")
cnn.Open "Provider=Microsoft.ACE.OleDb.12.0;Extended Properties='Excel 12.0;HDR=YES'; Data Source=" & ThisWorkbook.FullName
Sql = "select distinct 所属公司 from [总表$p2:p] where 所属公司 is not null"
arr = cnn.Execute(Sql).getrows
For i = 0 To UBound(arr, 2)
    Sql = "select 一级部门,二级部门,工号,姓名,入职日期,级别,缴费基数,公司缴费,个人缴费,合计缴费 from [总表$B2:p] " _
            & "where 所属公司='" & arr(0, i) & "' AND 级别 IN ('A级','B级')"
        rs.Open Sql, cnn, 1, 1
            If rs.RecordCount > 0 Then
                Sheets.Add AFTER:=Sheets(Sheets.Count)
                 ActiveSheet.Name = arr(0, i) & "-高管"
                 ActiveSheet.[A1] = Replace(Sheet1.[A1], "购买社保清单", "") & "在" & arr(0, i) & "公司购买社保清单_高管"
                GoSub 100
                rs.Close
            End If
            Sql = "select 一级部门,二级部门,工号,姓名,入职日期,级别,缴费基数,公司缴费,个人缴费,合计缴费 from [总表$B2:p] " _
            & "where 所属公司='" & arr(0, i) & "' AND 级别 not IN ('A级','B级')"
            If rs.State = 1 Then rs.Close
        rs.Open Sql, cnn, 1, 1
            If rs.RecordCount > 0 Then
                Sheets.Add AFTER:=Sheets(Sheets.Count)
                ActiveSheet.Name = arr(0, i) & "-非高管"
                 ActiveSheet.[A1] = Replace(Sheet1.[A1], "购买社保清单", "") & "在" & arr(0, i) & "公司购买社保清单_非高管"
                GoSub 100
                rs.Close
            End If
Next
cnn.Close: Set cnn = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
100:
                    With ActiveSheet
                        .[A2].Resize(1, 11) = BT
                        .[a3] = 1
                        .[B3].CopyFromRecordset rs
                        If rs.RecordCount > 1 Then
                            .Range("A3").AutoFill Destination:=Range("A3").Resize(rs.RecordCount), Type:=xlFillSeries
                        End If
                        R = .[a9999].End(3).Row
                        .Range("a2:k" & R).Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(9, 10, 11) _
        , Replace:=True, SummaryBelowData:=True
                        .Range("A1:K1").Merge
                        .[A1] = Replace(Sheet1.[A1], "购买社保清单", "") & "在" & arr(0, i) & "公司购买社保清单_高管"
                        .Cells.HorizontalAlignment = xlCenter
                        .Cells.VerticalAlignment = xlCenter
                        R = .[B9999].End(3).Row
                        .Range("a2:k" & R).Borders.LineStyle = 1
                        .[A1].Offset(R + 1, 0).Resize(1, 9) = DBT
                         .Columns("A:k").EntireColumn.AutoFit
                         .Cells.Font.Name = "微软雅黑"
                        .Cells.Font.Size = 10
                    End With
                    Return
End Sub

caicl

魂断蓝桥 发表于 2018-8-9 09:35
1、2
用此代码

格式就是按我附件里的分出来的表的：
1、把所有列调整在一页；
2、字体为自动缩小；
3、每列的列宽跟分出来的工作表的附件（如：A-非高管）一样，
另外分出来的工作表标题按总表中的：“2018年8月A公司购买社保清单”按分类自动更新成“2018年8月某公司在A公司购买社保清单-非高管/高管”，某公司可以取总表中的所属公司此列数据，此项现在分出来的时候A公司与某公司反了。
请帮忙看下能否调整下，谢谢！

caicl

魂断蓝桥 发表于 2018-8-9 09:35
1、2
用此代码

另外我发现标题非高管的命名显示的是高管，麻烦也看下是否能调整下？