|
- Sub 自动生成工资表()
- arr = Sheet1.[a1].CurrentRegion '把资料库 的A列到AE列的数据 赋值给数组Arr1
- Set d = CreateObject("scripting.dictionary")
- For I = 2 To UBound(arr)
- d(arr(I, 1)) = d(arr(I, 1)) & "," & I '把不同部门对应的行放入字典
- Next
- bm = ActiveSheet.[c2] '部门名称
- shname = Mid(bm, 4, 2) '根据部门名称确定需要生成的工作表名称(部门第四个字符开始,取2位)
- On Error Resume Next
- Application.DisplayAlerts = False
- Sheets(shname).Delete '如果已存在同名工作表,则删除
- Application.DisplayAlerts = True
- On Error GoTo 0
- ActiveSheet.Copy after:=Sheets(Sheets.Count)
- With ActiveSheet
- .Name = shname
- .Shapes.Range(Array("Button 1")).Delete '把 工作表的按钮删除
- xrr = Split(d(bm), ","): r = UBound(xrr)
- ReDim brr(1 To r, 1 To 32) '数组brr存放所要填充的内容
- For J = 1 To r
- k = Val(xrr(J)) '表示部门的各行
- brr(J, 1) = J: brr(J, UBound(brr, 2)) = J '第1列和最后1列:序号
- For m = 2 To 29
- brr(J, m) = arr(k, m)
- Next
- Next
- .[a4].Resize(UBound(brr), UBound(brr, 2)) = brr
- .Cells(4 + r, 1) = "合计(" & r & "人)"
- .Cells(4 + r, 1).Resize(1, 2).Merge
- .Cells(4 + r, 4).Resize(1, 24).Formula = "=sum(r4c:r[-1]c)" '加最后一行公式
- .Range("a3").Resize(r + 2, 32).Borders.LineStyle = 1 '加边框
- .Range("a4").Resize(r + 1, 32).ShrinkToFit = True '缩小字体填充
- End With
- End Sub
复制代码 |
|