VBA：机加车间个人绩效汇总（主要是涉及引用，还有计算）

已于 2024-07-11 13:40:08 修改
阅读量150 收藏 3
点赞数 7
分类专栏： EXCEL 文章标签： 需求分析
于 2024-06-28 15:29:36 首次发布
版权声明：本文为博主原创文章，遵循 CC 4.0 BY-SA 版权协议，转载请附上原文出处链接和本声明。
本文链接：https://blog.csdn.net/weixin_44819434/article/details/140043749
版权

几年前做的用EXCEL公式进行汇总，在最后汇总的时候，又要复制粘贴，又要要改公式中的单元格，有时会出错，所以干脆另外做个汇总的表格，当然，不是完全汇总，而是半汇总，源数据还是要从各个地方导出，然后将数据复制要各个工作表中去的

这个是数据源。这里已是将好几个地方的数据汇总在此了，界面上是个人绩效，是通过公式引用的，每个月都要新增、修改，挺烦的。挺想有个系统点一下就汇总，但小企业嘛，没办法，钉钉和ERP没打通，而且有很多因素在里面，很多数据要整理和调整一下才能用。
在这里插入图片描述
员工工时
在这里插入图片描述
出勤工时
在这里插入图片描述

标准工时差
在这里插入图片描述
数控提成
在这里插入图片描述

这个是做的汇总表，数据还是引用上面的已经汇总好的数据，做个引用和计算
在这里插入图片描述

Sub GETDATA()
 Dim SEARCHFILE As String, f As String
 Dim monthnum As Integer
 Dim targetbook As Workbook
 Dim sourceWorksheet As Worksheet, targetWorksheet As Worksheet
 Dim rng As Range, rngnew As Range
 Dim rowcount As Long, colcount As Long, i As Long, j As Long, k As Long, srowcount As Long, scolcount As Long
 Dim rownum As Integer, colnum As Integer
 Dim arr, sarr, tarr
 Dim GW As Integer, DJ As Integer
 Dim response As VbMsgBoxResult
 
 Set targetbook = ThisWorkbook
 Set targetWorksheet = ActiveSheet
 
 
Application.ScreenUpdating = False  '关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False   '不显示警告信息
 
 
 ''''获取当前表格的月份，月份放在A1上
monthnum = targetWorksheet.Range("A1")

response = MsgBox("当前统计的是" & monthnum & "月份的数据吗？", vbYesNo)

If response = vbYes Then

'''''打开源文件

 SEARCHFILE = "机加车间产出量*.xlsx"

 f = Dir(ThisWorkbook.Path & "\" & SEARCHFILE)
    If f = "" Then
        MsgBox "源文件不存，请查看"
        Exit Sub
    Else
        Set sourceWorkbook = Workbooks.Open(ThisWorkbook.Path & "\" & f, Password:="chr", ReadOnly:=True)
    End If

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'''''''激活“员工工时表”，用以获取员工及工时信息
  Worksheets("员工工时").Activate

  Set sourceWorksheet = sourceWorkbook.Worksheets("员工工时")
  
''''对工时源数据进行相关处理
  With sourceWorksheet
    rowcount = .Range("A2").End(xlDown).Row
    colcount = .Range("A2").End(xlToRight).Column
    
'   获取月份的工时所在的列号
    For i = 1 To colcount
      If .Cells(2, i) = monthnum & "月" Or .Cells(2, i) = "0" & monthnum & "月" Then
      colnum = i
      End If
    Next
    
    '''''将数据复制
    Set rng = .Range(.Cells(2, 1), .Cells(rowcount - 1, 1))
    Set rng = Union(rng, .Range(.Cells(2, colnum), .Cells(rowcount - 1, colnum)))

  End With
   Set arr = rng


''复制数据
targetWorksheet.Activate
 With targetWorksheet
   .Range("A2").Select
    arr.Copy .Range("A2")
 End With
 
 
'判断工时是否为空，为空删除
rowcount = 0
rowcount = targetWorksheet.Range("B" & Rows.Count).End(xlUp).Row '获取目标表总行数
For j = rowcount To 2 Step -1
   If Range("B" & j).Value = "" Or IsEmpty(Range("B" & j).Value) Then
     Rows(j).Delete Shift:=xlUp
   End If
Next j


Set tarr = targetWorksheet.Range("A1:Z" & rowcount) '目标表范围

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''获取出勤工时

sourceWorksheet.Activate
Worksheets("出勤时间").Activate

'   获取月份的工时所在的列号
    For i = 1 To 24
      If Cells(3, i) = monthnum & "月" Or Cells(3, i) = "0" & monthnum & "月" Then
      scolnum = i
      End If
    Next

   srowcount = Cells(Rows.Count, 1).End(xlUp).Row '获取源表行数
'
ReDim sarr(1 To srowcount, 1 To 2)
Set sarr = ActiveSheet.Range(Cells(1, scolnum), Cells(srowcount, scolnum + 1)) '获取当月的出勤工时,装入sarr


targetWorksheet.Activate ''转回目标表
''遍历复制出勤工时
With targetWorksheet
For i = 2 To rowcount
    For j = 1 To srowcount
     If .Range("A" & i).Value = sarr(j, 1).Value2 Then
         .Range("C" & i).Value = sarr(j, 2).Value2
     End If
    
    Next
Next
End With

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''获取工时对比的工时差
sourceWorksheet.Activate
Worksheets("工时对比").Activate

'   获取月份的工时所在的列号
    For i = 1 To 24
      If Cells(1, i) = monthnum & "月" Or Cells(3, i) = "0" & monthnum & "月" Then
      scolnum = i
      End If
    Next

   srowcount = Cells(Rows.Count, 1).End(xlUp).Row '获取源表行数
'
ReDim sarr(1 To srowcount, 1 To 2)
Set sarr = ActiveSheet.Range(Cells(1, scolnum), Cells(srowcount, scolnum + 1)) '获取当月的工时差,装入sarr


targetWorksheet.Activate ''转回目标表
With targetWorksheet
''遍历复制工时差
For i = 2 To rowcount
    For j = 1 To srowcount
     If .Range("A" & i).Value = sarr(j, 1).Value2 Then
         .Range("D" & i).Value = sarr(j, 2).Value2
     End If
    
    Next
''''计算产出率和超产工时
  If IsNumeric(.Range("C" & i).Value) And .Range("C" & i).Value > 0 Then
  .Range("E" & i).Value = (.Range("B" & i).Value + .Range("D" & i).Value) / .Range("C" & i).Value * 100 & "%"
  .Range("F" & i).Value = Round((.Range("B" & i).Value + .Range("D" & i).Value - .Range("C" & i).Value) / 60, 2)
  End If
Next
End With

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''获取出勤工时

sourceWorksheet.Activate
Worksheets("数控组提成").Activate

Set arr = Range("A66:Z100")

'   获取月份的工时所在的列号
    For i = 1 To 24
      If arr(1, i) = monthnum & "月" Or arr(1, i) = "0" & monthnum & "月" Then
      scolnum = i
      End If
    Next

   srowcount = arr.Rows.Count '获取源表行数
'

ReDim sarr(1 To srowcount, 1 To 2)
For i = 1 To srowcount
   Set sarr(i, 1) = arr(i, 1) '获取姓名
   Set sarr(i, 2) = arr(i, scolnum + 1) '获取提成
Next

targetWorksheet.Activate ''转回目标表


''遍历复制提成
With targetWorksheet
For i = 2 To rowcount
 .Range("G" & i).Value = 0
    For j = 1 To srowcount

     If .Range("A" & i).Value = sarr(j, 1).Value2 Then
         .Range("G" & i).Value = sarr(j, 2).Value2

     End If
    
    Next
    
Next
End With

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''关闭源工作簿，并不保存更改
sourceWorkbook.Close SaveChanges:=False


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''设置岗位系数
DJ = Worksheets("参数").Range("E1") '获取工时单价

ReDim sarr(1 To 20, 1 To 2)
Set sarr = Worksheets("参数").Range("A1:B20") '获取岗位系数

rowcount = targetWorksheet.Range("A" & Rows.Count).End(xlUp).Row '重新获取目标表总行数

''理论绩效的计算
For i = 3 To rowcount
    Range("H" & i).Value = Range("F" & i).Value * 1 * DJ + Range("G" & i).Value
    For j = 1 To srowcount
     If Range("A" & i).Value = sarr(j, 1).Value2 Then
         Range("H" & i).Value = Range("F" & i).Value * sarr(j, 2).Value2 * DJ + Range("G" & i).Value
     End If
    
    Next
   Range("K" & i).FormulaR1C1 = "=RC[-3]+RC[-2]+RC[-1]" ''增加综合提成的公式
Next


 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''设置格式
Range("A2").Value = "姓名"
Range("B2").Value = "实作工时"
Range("C2").Value = "出勤工时"
Range("D2").Value = "工时差"
Range("E2").Value = "产出率"
Range("F2").Value = "超产工时(H)"
Range("G2").Value = "数控组提成"
Range("H2").Value = "理论绩效"
Range("I2").Value = "技能补贴"
Range("J2").Value = "质量扣除"
Range("K2").Value = "综合提成"

'调整格式
  moformat.moformat

ElseIf response = vbNo Then
        MsgBox "请重新选择"
End If


Application.ScreenUpdating = True
Application.DisplayAlerts = True


End Sub

三个按钮的代码

'汇总
Private Sub CommandButton1_Click()
  GETDATA.GETDATA
  CommandButton1.Enabled = False
  CommandButton3.Enabled = False
End Sub

'解锁
Private Sub CommandButton2_Click()
  Dim passInput As String
    passInput = InputBox("请输入解锁密码：", "password")

  If UCase(passInput) = "CHR" Then

  CommandButton1.Enabled = True
  CommandButton3.Enabled = True
  Else
  MsgBox "密码错误"
  End If
End Sub

'清除
Private Sub CommandButton3_Click()
  Dim rowcount As Integer
  
  rowcount = ActiveSheet.Range("A1").End(xlDown).Row
  
  
  If rowcount = 0 Then
  Exit Sub
  Else
    Rows("2:" & rowcount).Select
    Selection.Delete Shift:=xlUp
  End If
  CommandButton3.Enabled = False
End Sub

自动计算的代码

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim rng As Range
   Dim cells As Range
   Dim selectrow As Long, selectcol As Long
   Dim rngI As Range, rngJ As Range

'''
'   Set rng = Range("I3:J50") '这个范围的数据有变化时才起作用
'   Application.EnableEvents = False ' 暂时禁用事件，防止触发无限循环
'
'   If Not Intersect(Target, rng) Is Nothing Then
'      For Each cells In Intersect(Target, rng)
'        selectrow = cells.Row
'        selectcol = cells.Column
''   MsgBox "当前行号是:" & selectrow & ",当前列号是:" & selectcol
'        If selectcol = 9 Then
'         Range("k" & selectrow) = Range("H" & selectrow) + cells + Range("J" & selectrow)
'        ElseIf selectcol = 10 Then
'         Range("k" & selectrow) = Range("H" & selectrow) + Range("i" & selectrow) + cells
'
'        End If
'
'
'      Next cells
'
'   End If
''

'
Set rngI = Range("I3:I50") '技能补贴范围
Set rngJ = Range("J3:J50") '质量扣除范围
Application.EnableEvents = False ' 暂时禁用事件，防止触发无限循环

'技能补贴录入
If Not Intersect(Target, rngI) Is Nothing Then
   For Each cells In Intersect(Target, rngI)
     selectrow = cells.Row
     selectcol = cells.Column
'   MsgBox "当前行号是:" & selectrow & ",当前列号是:" & selectcol
     Range("k" & selectrow) = Range("H" & selectrow) + cells + Range("J" & selectrow)
   Next cells
End If


'质量扣除录入
If Not Intersect(Target, rngJ) Is Nothing Then
   For Each cells In Intersect(Target, rngJ)
     selectrow = cells.Row
     selectcol = cells.Column
'     MsgBox "当前行号是:" & selectrow & ",当前列号是:" & selectcol
     Range("k" & selectrow) = Range("H" & selectrow) + Range("i" & selectrow) + cells
   Next cells
End If
        
    
Application.EnableEvents = True ' 重新启用事件
   
   
End Sub
锁匙isthekey
关注
  • 7
    点赞
  • 踩
  • 3
    收藏
    觉得还不错? 一键收藏
  • 0
    评论
专栏目录
评论
添加红包

请填写红包祝福语或标题

个

红包个数最小为10个

元

红包金额最低5元

当前余额3.43元 前往充值 >
需支付：10.00元
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付元
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明：

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。

余额充值