帮同事做了一个生成薪资报表的VBA

2016年2月2日10:21:49 发表评论 3

朗新EHR的报表系统所导出的数据无法直接应用,如果让软件公司去修改的话,估计又是个巨大的工程,期间还可能会引发这样或那样的问题,于是帮同事用VBA做了一个小程序。Excel是ERP数据通往实际使用的最后1公里,今天再次验证了这句话。

原本大半天的工作,现在只需要不到1分钟就能搞定。

需求中有一个特殊之处:A部门下面有A1A2A3等等几个子部门,在生成报表的时候需要把子部门的数据汇总合计到上级部门中。子部门可能会发生变化。

在处理时,增加了一个部门信息维护sheet,通过自定义名称的方式将子部门与上级部门关联,在计算过程中,如果子部门包含于当前上级部门的子集中(也就是在所属的自定义名称区域内),就将数据相加,否则就忽略继续向下查找。代码中蓝色部分就是用来实现这个功能的。

其他语句没有什么太特别的地方。

Sub 部门维护()
Sheets("部门信息维护").Visible = True
Sheets("部门信息维护").Select
End Sub

Sub 部门信息维护()
Range("a1:g1").Select
Selection.SpecialCells(xlCellTypeConstants, 23).Select
Selection.CreateNames Top:=False, Left:=True, Bottom:=False, Right:= _
False
Columns("B:F").Select
Selection.SpecialCells(xlCellTypeConstants, 23).Select
Selection.CreateNames Top:=True, Left:=False, Bottom:=False, Right:= _
False
'Range("E7").Select
' Sheets("部门信息维护").Select
'ActiveWindow.SelectedSheets.Visible = False
Columns("H:AP").Select
Selection.SpecialCells(xlCellTypeConstants, 23).Select
Selection.CreateNames Top:=True, Left:=False, Bottom:=False, Right:= _
False
Sheets("部门信息维护").Visible = xlSheetVeryHidden
Sheets("目录").Select
End Sub

Sub 报表处理页()
Sheets("报表处理页").Select
Rows("2:100").Select
Selection.Delete Shift:=xlUp
'行政办公楼部门名称
Dim XZ, XZ1 As Integer
Dim X1 As Range
Set X1 = Worksheets("部门信息维护").Range("行政办公楼")
arr = X1
XZ = Application.CountA(Worksheets("部门信息维护").Range("行政办公楼"))
For XZ1 = 1 To XZ
Worksheets("报表处理页").Range("B" & XZ1 + 1) = arr(XZ1, 1)
Next
'营销中心部门名称
Dim YX, YX1 As Integer
Dim Y1 As Range
Set Y1 = Worksheets("部门信息维护").Range("营销中心")
arr = Y1
YX = Application.CountA(Worksheets("部门信息维护").Range("营销中心"))
For YX1 = 1 To YX
Worksheets("报表处理页").Range("B" & YX1 + XZ + 1) = arr(YX1, 1)
Next
'生产中心部门名称
Dim SC, SC1 As Integer
Dim S1 As Range
Set S1 = Worksheets("部门信息维护").Range("生产中心")
arr = S1
SC = Application.CountA(Worksheets("部门信息维护").Range("生产中心"))
For SC1 = 1 To SC
Worksheets("报表处理页").Range("B" & SC1 + YX + XZ + 1) = arr(SC1, 1)
Next
'成品库部门名称
Dim CP, CP1 As Integer
Dim C1 As Range
Set C1 = Worksheets("部门信息维护").Range("成品库")
arr = C1
CP = Application.CountA(Worksheets("部门信息维护").Range("成品库"))
For CP1 = 1 To CP
Worksheets("报表处理页").Range("B" & CP1 + SC + YX + XZ + 1) = arr(CP1, 1)
Next
'其它部门名称
Dim QT, QT1 As Integer
Dim Q1 As Range
Set Q1 = Worksheets("部门信息维护").Range("其它")
arr = Q1
QT = Application.CountA(Worksheets("部门信息维护").Range("其它"))
For QT1 = 1 To QT
Worksheets("报表处理页").Range("B" & QT1 + CP + SC + YX + XZ + 1) = arr(QT1, 1)
Next
Worksheets("报表处理页").Range("A2:a" & XZ + 1).MergeCells = True
Worksheets("报表处理页").Range(Range("A" & XZ + 2), Range("A" & XZ).Offset(YX)).MergeCells = True
Worksheets("报表处理页").Range(Range("A" & YX + XZ + 2), Range("A" & YX + XZ).Offset(SC)).MergeCells = True
Worksheets("报表处理页").Range(Range("A" & SC + YX + XZ + 2), Range("A" & SC + YX + XZ).Offset(CP)).MergeCells = True
Worksheets(" 报表处理页").Range(Range("A" & CP + SC + YX + XZ + 2), Cells(Application.CountA(Worksheets("报表处理页").Range("B:B")) + 1, 1)).MergeCells = True  '该语句无法实现?
'Worksheets("报表处理页").Range(Range("A" & CP + SC + YX + XZ + 2), Range("A" & SC + YX + XZ).Offset(QT)).MergeCells = True  '该语句无法实现?
'部门名称
Dim BMM, BMM1 As Integer
Dim BMMM1 As Range
Set BMMM1 = Worksheets("部门信息维护").Range("部门")
arr = BMMM1
BMM = Application.CountA(Worksheets("部门信息维护").Range("部门"))
Worksheets("报表处理页").Range("a2") = arr(BMM1 + 1, 1)
Worksheets("报表处理页").Range("A" & XZ + 2) = arr(BMM1 + 1, 2)
Worksheets("报表处理页").Range("A" & YX + XZ + 2) = arr(BMM1 + 1, 3)
Worksheets("报表处理页").Range("A" & SC + YX + XZ + 2) = arr(BMM1 + 1, 4)
Worksheets("报表处理页").Range("A" & CP + SC + YX + XZ + 2) = arr(BMM1 + 1, 5)
With Worksheets("报表处理页").Range("A:A")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Dim bbhs As Integer
For bbhs = 2 To Application.CountA(Worksheets("报表处理页").Range("B:B")) + 1
'For bbhs = 2 To Worksheets("报表处理页").Range("B:B").Item(ActiveSheet.UsedRange.Count).Row
Dim renshu, yingfa, yanglao, shiye, yiliao, dae, zhufang, geshui, shuihou, jiekuan, bukuan, shifa As Single
Dim HS As Integer
'For HS = 1 To Application.CountA(Worksheets("数据源").Range("B:B"))  '根据数据源行数判断循环上限
For HS = 1 To Worksheets("数据源").Range("B:B").Item(ActiveSheet.UsedRange.Count).Row  '根据数据源行数判断循环上限
If WorksheetFunction.CountIf(Range(Worksheets("报表处理页").Range("B" & bbhs)), Worksheets("数据源").Range("B" & HS)) <> 0 Then
renshu = renshu + Worksheets("数据源").Range("C" & HS)
yingfa = yingfa + Worksheets("数据源").Range("D" & HS)
yanglao = yanglao + Worksheets("数据源").Range("E" & HS)
shiye = shiye + Worksheets("数据源").Range("F" & HS)
yiliao = yiliao + Worksheets("数据源").Range("G" & HS)
dae = dae + Worksheets("数据源").Range("H" & HS)
zhufang = zhufang + Worksheets("数据源").Range("I" & HS)
geshui = geshui + Worksheets("数据源").Range("J" & HS)
shuihou = shuihou + Worksheets("数据源").Range("K" & HS)
jiekuan = jiekuan + Worksheets("数据源").Range("L" & HS)
bukuan = bukuan + Worksheets("数据源").Range("M" & HS)
shifa = shifa + Worksheets("数据源").Range("N" & HS)
End If
Next HS
Worksheets("报表处理页").Range("C" & bbhs) = renshu
Worksheets("报表处理页").Range("D" & bbhs) = yingfa
Worksheets("报表处理页").Range("E" & bbhs) = yanglao
Worksheets("报表处理页").Range("F" & bbhs) = shiye
Worksheets("报表处理页").Range("G" & bbhs) = yiliao
Worksheets("报表处理页").Range("H" & bbhs) = dae
Worksheets("报表处理页").Range("I" & bbhs) = zhufang
Worksheets("报表处理页").Range("J" & bbhs) = geshui
Worksheets("报表处理页").Range("K" & bbhs) = shuihou
Worksheets("报表处理页").Range("L" & bbhs) = jiekuan
Worksheets("报表处理页").Range("M" & bbhs) = bukuan
Worksheets("报表处理页").Range("N" & bbhs) = shifa
renshu = 0
yingfa = 0
yanglao = 0
shiye = 0
yiliao = 0
dae = 0
zhufang = 0
geshui = 0
shuihou = 0
jiekuan = 0
bukuan = 0
shifa = 0
Next
Range(Cells(1, 1), Cells(Application.CountA(Worksheets("报表处理页").Range("B:B")) + 1, 14)).Select
With Selection
.HorizontalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.NumberFormatLocal = "0.00_ "
End Sub

Sub 数据导入()
'Dim fil As String
Sheets("数据源").Visible = True
Sheets("数据源").Select
Rows("4:200").Select
Selection.Delete Shift:=xlUp
'fil = Application.GetOpenFilename(filefilter:="Excel 97-2003工作薄(*.xls),*.xls,Excel工作簿(*.xlsx),*.xlsx")
Range("B4").Select
End Sub
Sub 数据导入完成()
Sheets("数据源").Visible = xlSheetVeryHidden
Sheets("目录").Select
End Sub
Sub 数据导出()
Dim RQ As String
RQ = InputBox(prompt:="请输入薪资报表属期", Default:=Year(Date) & "年" & Month(Date) & "月")
Worksheets.Add(before:=Worksheets(1)).Name = RQ & "薪资报表"
Worksheets("报表处理页").Range("a1:n65536").Select
Selection.Copy
Sheets(RQ & "薪资报表").Select
Range("A1").Select
ActiveSheet.Paste
End Sub

 

发表评论

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen: