Excel·VBA江西省预算一体化工资表一键处理

每月制作工资表导出为Excel后都需要调整格式，删除0数据的列、对工资表项目进行排序、打印设置等等，有些单位还分有“行政”、“事业”2个工资表就需要操作2次。显然，这种重复操作的问题，可以使用VBA代码解决

代码使用说明

• 代码作用范围：以下代码作用于活动工作簿/工作表，无需将待处理的工资表保存在启用宏的工作簿中（xlsm格式），只要待处理的工资表处于活动状态即可运行代码。同时，也不建议把数据保存在xlsm文件中，vba代码运行结果是无法撤销的
  活动工作簿：如果打开多个工作簿，显示在最前面的就是活动工作簿
  活动工作表：活动工作簿当前显示的工作表

1，工资表格式处理

涉及功能

• 数据调整：工资表各项目按指定顺序排序，添加合计数行，删除合计数为0的列，删除无意义项目列（应发合计、扣款合计），添加工资表所属月份，添加个税所属月份，添加制表人及时间
  参数bt可指定工资表各项目的顺序，如果工资表中存在某项不在参数bt内，且合计数不为0的，则该列排序在最后一列
• 格式设置：行高、自适应列宽、文字居中、自动换行、隐藏指定列、所有框线
  存在部分列设置自适应列宽，但效果不佳的，可以在代码运行后手工调整
• 打印设置：横向打印、页边距、打印标题、打印页脚、冻结表格

Sub 工资表格式处理()
    '将每月2张工资表放在同一工作簿中，分别命名“行政、事业”，运行本代码
    Dim title_row, title_h, row_h, bt, brr, ws, start_col&, b, i&, j&, gs&
    title_row = 3: title_h = 13.2: row_h = 24  '表头行数，前2行行高，其他行高
    zbr_name = "制表人：薛定谔  " & Format(Date, "yyyy.mm.dd")
    bt = "职务工资,级别工资,岗位工资,薪级（技术）工资,教师（10%）," _
    & "绩效奖金,生活补助,工作津贴,岗位津贴,降温取暖费,公车改革补贴," _
    & "补发工资（停发）,应发工资,养老保险,职业年金,医疗保险,失业保险," _
    & "住房公积金,代扣个税,单位代扣小计,代扣其它,实发合计"  '表头及顺序
    brr = Split(bt, ",")
    For Each ws In ActiveWorkbook.Worksheets
        With ws
            '格式设置：行高、居中、自动换行、合并单元格、隐藏D-E列
            .Rows.RowHeight = row_h: .Rows("1:2").RowHeight = title_h
            .Rows(3).RowHeight = 25.2    '第3行行高
            .Cells.HorizontalAlignment = xlCenter  '全表居中
            .Cells.VerticalAlignment = xlCenter
            .Rows(3).WrapText = True     '第3行自动换行
            .Columns(2).WrapText = True  '第2列自动换行，单位名称
            .Cells(1, 1).UnMerge    '取消合并单元格，方便调整列排序
            .Columns("d:e").Hidden = True
            '添加合计行，删除合计数为零的列，删除“应发合计,扣款合计”列
            hb_row = .UsedRange.Rows.count + 1: .Cells(hb_row, 3) = "合计"
            For j = 6 To .UsedRange.Columns.count
                .Cells(hb_row, j).FormulaR1C1 = "=SUM(R[" & 4 - hb_row & "]C[0]:R[-1]C[0])"
            Next
            For j = .UsedRange.Columns.count To 6 Step -1
                If .Cells(hb_row, j) = 0 Or .Cells(3, j) = "应发合计" _
                Or .Cells(3, j) = "扣款合计" Then .Columns(j).Delete
            Next
            '调整列排序，剪切列、插入列
            start_col = 6  '开始列号
            For Each b In brr
                For j = 6 To .UsedRange.Columns.count
                    If .Cells(3, j) = b Then
                        If j <> start_col Then
                            .Columns(j).Cut
                            .Columns(start_col).Insert
                        End If
                        start_col = start_col + 1: Exit For  '递增、跳出
                    End If
                Next
            Next
            If Month(Date) = 1 Then gs = 12 Else gs = Month(Date) - 1  '个税所属月份
            For j = .UsedRange.Columns.count To 6 Step -1
                If .Cells(3, j) = "代扣个税" Then .Cells(3, j) = "代扣" & gs & "月个税": Exit For
            Next
            '增加第1列序号列，表头合并单元格，所有框线，列宽自适应
            .Columns(1).Insert: .Cells(3, 1) = "序号"
            For i = 4 To .UsedRange.Rows.count - 1
                .Cells(i, 1) = i - 3
            Next
            .Cells(1, 2) = Replace(.Cells(1, 2).Value, "局", "局" & Month(Date) & "月")
            .Cells(1, 1).Resize(2, .UsedRange.Columns.count).Merge
            .UsedRange.Borders.LineStyle = xlContinuous
            Range(.Columns(7), .Columns(.UsedRange.Columns.count)).ColumnWidth = 4
            Range(.Columns(7), .Columns(.UsedRange.Columns.count)).AutoFit
            Range(.Columns(1), .Columns(2)).AutoFit: .Columns(4).AutoFit
            .Cells(.UsedRange.Rows.count + 1, .UsedRange.Columns.count - 2) = zbr_name
            '设置工作表横向打印、页边距、打印标题、打印页脚、冻结表格
            With .PageSetup
                .Orientation = xlLandscape  '横向打印
                .PrintTitleRows = "$1:$3"   '打印标题
                .TopMargin = Application.InchesToPoints(0.787)     '上边距2厘米
                .BottomMargin = Application.InchesToPoints(0.787)  '下边距2厘米
                .CenterFooter = "第 &P 页，共 &N 页"  '打印页脚
            End With
        End With
    Next
End Sub

举例

系统导出工资表，保存至同一个工作簿的不同工作表（部分截图）

代码处理后工资表

2，工资表数据统计

为便于账务处理以及数据核对，对以上经过代码处理的工资表进行数据统计
工资收入部分分别计入：基本工资、津贴补贴、绩效奖金

Sub 工资表数据统计()
    '仅适用于统计经过以上代码处理的工资表
    Dim dict1 As Object, dict2 As Object, jb$, jbt$, arr, brr, ws, res, i&, j&, gzxm$
    jb = "职务工资,级别工资,岗位工资,薪级（技术）工资,教师（10%）"  '基本工资
    jbt = "生活补助,工作津贴,岗位津贴,降温取暖费,公车改革补贴"      '津贴补贴
    title_row = 3: start_col = 7  '表头行号，开始列号
    Set dict1 = CreateObject("scripting.dictionary")
    brr = Split(jb, ",")
    For Each b In brr
        dict1(b) = "基本工资"
    Next
    brr = Split(jbt, ",")
    For Each b In brr
        dict1(b) = "津贴补贴"
    Next
    Set dict2 = CreateObject("scripting.dictionary")
    Set dict2("基本工资") = CreateObject("scripting.dictionary")  '字典嵌套
    Set dict2("津贴补贴") = CreateObject("scripting.dictionary")
    For Each ws In ActiveWorkbook.Worksheets
        arr = ws.UsedRange.Value: ws_name = ws.Name: s = s + "," + ws_name
        total_row = ws.UsedRange.Rows.count - 1  '合计行号
        For j = start_col To UBound(arr, 2)
            gzxm = arr(title_row, j)  '工资项目
            If Not dict1.Exists(gzxm) And Not dict2.Exists(gzxm) Then  '不属于基本工资、津贴补贴
                Set dict2(gzxm) = CreateObject("scripting.dictionary")
            ElseIf dict1.Exists(gzxm) Then
                gzxm = dict1(gzxm)    '属于基本工资、津贴补贴，则转换
            End If
            dict2(gzxm)(ws_name) = dict2(gzxm)(ws_name) + arr(total_row, j)
        Next
    Next
    k2 = dict2.keys: brr = Split(s, ",")  '字典dict2所有键转为数组，拆分字符串s
    ReDim res(1 To dict2.count + 1, 1 To UBound(brr) + 2)  '统计结果数组
    '横纵条件赋值到数组
    For i = 2 To UBound(res)  '纵向
        res(i, 1) = k2(i - 2)
    Next
    For j = 1 To UBound(brr)  '横向
        res(1, j + 1) = brr(j)
    Next
    res(1, UBound(res, 2)) = "合计"
    '数组结果赋值到res数组
    For i = 2 To UBound(res)  '纵向
        For j = 2 To UBound(res, 2) - 1  '横向
            If dict2(res(i, 1)).Exists(res(1, j)) Then
                res(i, j) = dict2(res(i, 1))(res(1, j))
                res(i, UBound(res, 2)) = res(i, UBound(res, 2)) + res(i, j)
            End If
        Next
    Next
    Worksheets.Add(After:=Sheets(Sheets.count)).Name = "统计"  '添加工作表并命名
    Worksheets("统计").[a1].Resize(UBound(res), UBound(res, 2)) = res
    With Worksheets("统计")  '格式设置
        .Cells.Font.Name = "宋体": .Cells.Font.Size = 12: .Rows.RowHeight = 20
        .Cells.HorizontalAlignment = xlCenter  '全表居中
        .Cells.VerticalAlignment = xlCenter
        Range(.Columns(1), .Columns(.UsedRange.Columns.count)).AutoFit
    End With
End Sub

举例

对1-举例处理结果进行统计：
部分统计结果的顺序可能需要手工调整，如失业保险