社保按公司自动分表

魂断蓝桥

caicl 发表于 2018-8-10 14:59
另外我发现标题非高管的命名显示的是高管，麻烦也看下是否能调整下？

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
                        .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

jiminyanyan

蓝桥老师挺有耐心的．．．

caicl

魂断蓝桥 发表于 2018-8-13 08:27
Option Explicit

Sub a()

这个新代码好像还是无法解决我想要的格式，能麻烦蓝桥老师再帮忙看下吗？
一、格式就是按我附件里的分出来的表的：
1、把所有列调整在一页；
2、字体为自动缩小；
3、每列的列宽和行距等跟我提供的附件里的表格（A-非高管）一样。
二、分出来的工作表标题按总表中的：“2018年8月A公司购买社保清单”按分类自动更新成“2018年8月某公司在A公司购买社保清单-非高管/高管”，某公司可以取总表中的所属公司此列数据，此项现在分出来的时候A公司与某公司反了。
请帮忙看下能否调整下，谢谢！

不知道为什么

caicl 发表于 2018-8-17 16:36
这个新代码好像还是无法解决我想要的格式，能麻烦蓝桥老师再帮忙看下吗？
一、格式就是按我附件里的分出 ...

这典型的就是找人代工啊。字体行距等就是不会，你录制下宏也能捣鼓出来啊

静等蓝桥老师！

xiangbaoan

瞬间觉得 魂断蓝桥  高大上…………