[已解决]VBA年龄工龄计算问题

龙送农

VBA年龄工龄计算问题：M列和O列有数据时，自动计算“年龄”和“工龄”在N列P列，切换到“数据表”时，自动执行，达到附件公式效果。

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-6-17 09:18

代码放在sheet1的工作表事件中，但是我算的工龄有几个会相差一年，你先看下吧：

1. Private Sub Worksheet_Activate()
   
2.     Dim arr, y1 As Date, y2 As Date, y As Date, i&, n&
   
3.     n = Sheet1.Cells(Rows.Count, 13).End(xlUp).Row
   
4.     arr = Sheet1.Range("M5:p" & n)
   
5.     y = CDate(Left(Cells(2, 8), 4) & "-" & Mid(Cells(2, 8), InStr(Cells(2, 8), ".") + 1, 2) & "-01")
   
6.     For i = 1 To n - 4
   
7.         If arr(i, 1) <> "" And arr(i, 3) <> "" Then
   
8.             y1 = CDate(Left(arr(i, 1), 4) & "-" & Mid(arr(i, 1), InStr(arr(i, 1), ".") + 1, 2) & "-01")
   
9.             y2 = CDate(Left(arr(i, 3), 4) & "-" & Mid(arr(i, 3), InStr(arr(i, 3), ".") + 1, 2) & "-01")
   
10.             arr(i, 2) = DateDiff("yyyy", y1, Date)
    
11.             arr(i, 4) = DateDiff("yyyy", y2, y)
    
12.         End If
    
13.     Next
    
14.     Sheet1.Range("M5").Resize(n - 4, 4) = arr
    
15. End Sub
    
16. 
    
17. Private Sub Worksheet_Change(ByVal Target As Range)
    
18.     Dim r&, y1 As Date, y2 As Date, y As Date
    
19.     If Target.Count > 1 Then Exit Sub
    
20.     If Target.Column = 13 Or Target.Column = 15 Then
    
21.         r = Target.Row
    
22.         If Cells(r, 13) <> "" And Cells(r, 15) <> "" Then
    
23.             y1 = CDate(Left(Cells(r, 13), 4) & "-" & Mid(Cells(r, 13), InStr(Cells(r, 13), ".") + 1, 2) & "-01")
    
24.             y2 = CDate(Left(Cells(r, 15), 4) & "-" & Mid(Cells(r, 15), InStr(Cells(r, 15), ".") + 1, 2) & "-01")
    
25.             y = CDate(Left(Cells(2, 8), 4) & "-" & Mid(Cells(2, 8), InStr(Cells(2, 8), ".") + 1, 2) & "-01")
    
26.             Cells(r, 14) = DateDiff("yyyy", y1, Date)
    
27.             Cells(r, 16) = DateDiff("yyyy", y2, y)
    
28.         End If
    
29.     End If
    
30. End Sub

复制代码

跳转到最佳答案楼层

老司机带带我

代码放在sheet1的工作表事件中，但是我算的工龄有几个会相差一年，你先看下吧：

1. Private Sub Worksheet_Activate()
   
2.     Dim arr, y1 As Date, y2 As Date, y As Date, i&, n&
   
3.     n = Sheet1.Cells(Rows.Count, 13).End(xlUp).Row
   
4.     arr = Sheet1.Range("M5:p" & n)
   
5.     y = CDate(Left(Cells(2, 8), 4) & "-" & Mid(Cells(2, 8), InStr(Cells(2, 8), ".") + 1, 2) & "-01")
   
6.     For i = 1 To n - 4
   
7.         If arr(i, 1) <> "" And arr(i, 3) <> "" Then
   
8.             y1 = CDate(Left(arr(i, 1), 4) & "-" & Mid(arr(i, 1), InStr(arr(i, 1), ".") + 1, 2) & "-01")
   
9.             y2 = CDate(Left(arr(i, 3), 4) & "-" & Mid(arr(i, 3), InStr(arr(i, 3), ".") + 1, 2) & "-01")
   
10.             arr(i, 2) = DateDiff("yyyy", y1, Date)
    
11.             arr(i, 4) = DateDiff("yyyy", y2, y)
    
12.         End If
    
13.     Next
    
14.     Sheet1.Range("M5").Resize(n - 4, 4) = arr
    
15. End Sub
    
16. 
    
17. Private Sub Worksheet_Change(ByVal Target As Range)
    
18.     Dim r&, y1 As Date, y2 As Date, y As Date
    
19.     If Target.Count > 1 Then Exit Sub
    
20.     If Target.Column = 13 Or Target.Column = 15 Then
    
21.         r = Target.Row
    
22.         If Cells(r, 13) <> "" And Cells(r, 15) <> "" Then
    
23.             y1 = CDate(Left(Cells(r, 13), 4) & "-" & Mid(Cells(r, 13), InStr(Cells(r, 13), ".") + 1, 2) & "-01")
    
24.             y2 = CDate(Left(Cells(r, 15), 4) & "-" & Mid(Cells(r, 15), InStr(Cells(r, 15), ".") + 1, 2) & "-01")
    
25.             y = CDate(Left(Cells(2, 8), 4) & "-" & Mid(Cells(2, 8), InStr(Cells(2, 8), ".") + 1, 2) & "-01")
    
26.             Cells(r, 14) = DateDiff("yyyy", y1, Date)
    
27.             Cells(r, 16) = DateDiff("yyyy", y2, y)
    
28.         End If
    
29.     End If
    
30. End Sub

复制代码

龙送农

老司机带带我 发表于 2016-6-17 09:18
代码放在sheet1的工作表事件中，但是我算的工龄有几个会相差一年，你先看下吧：

还是按您的算法，我的公式是按年算，实际应该是按月足年算才合。谢谢老师！

suye1010

把以下类似的计算语句
Cells(r, 16) = DateDiff("yyyy", y2, y)
更改为
Cells(r, 16) = DateDiff("d", y2, y)\365

龙送农

老司机带带我 发表于 2016-6-17 09:18
代码放在sheet1的工作表事件中，但是我算的工龄有几个会相差一年，你先看下吧：

老师：有如下两个问题
1、我加了一列，代码怎样修改

Private Sub Worksheet_Activate()

Call test
    Dim arr, y1 As Date, y2 As Date, y As Date, i&, n&
    n = Sheet1.Cells(Rows.Count, 14).End(xlUp).Row
    arr = Sheet1.Range("n5:q" & n)
    y = CDate(Left(Cells(2, 8), 4) & "-" & Mid(Cells(2, 8), InStr(Cells(2, 8), ".") + 1, 2) & "-01")
    For i = 1 To n - 4
        If arr(i, 1) <> "" And arr(i, 3) <> "" Then
            y1 = CDate(Left(arr(i, 1), 4) & "-" & Mid(arr(i, 1), InStr(arr(i, 1), ".") + 1, 2) & "-01")
            y2 = CDate(Left(arr(i, 3), 4) & "-" & Mid(arr(i, 3), InStr(arr(i, 3), ".") + 1, 2) & "-01")
            arr(i, 2) = DateDiff("yyyy", y1, Date)
            arr(i, 4) = DateDiff("yyyy", y2, y)
        End If
    Next
    Sheet1.Range("n5").Resize(n - 4, 4) = arr
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r&, y1 As Date, y2 As Date, y As Date
    If Target.Count > 1 Then Exit Sub
    If Target.Column = 14 Or Target.Column = 16 Then
        r = Target.Row
        If Cells(r, 14) <> "" And Cells(r, 16) <> "" Then
            y1 = CDate(Left(Cells(r, 14), 4) & "-" & Mid(Cells(r, 14), InStr(Cells(r, 14), ".") + 1, 2) & "-01")
            y2 = CDate(Left(Cells(r, 16), 4) & "-" & Mid(Cells(r, 16), InStr(Cells(r, 16), ".") + 1, 2) & "-01")
            y = CDate(Left(Cells(2, 8), 4) & "-" & Mid(Cells(2, 8), InStr(Cells(2, 8), ".") + 1, 2) & "-01")
            Cells(r, 15) = DateDiff("yyyy", y1, Date) \ 365
            Cells(r, 17) = DateDiff("yyyy", y2, y) \ 365
        End If
    End If


End Sub

龙送农

suye1010 发表于 2016-6-17 13:33
把以下类似的计算语句
Cells(r, 16) = DateDiff("yyyy", y2, y)
更改为

谢谢提示！

龙送农

老司机带带我 发表于 2016-6-17 09:18
代码放在sheet1的工作表事件中，但是我算的工龄有几个会相差一年，你先看下吧：

老师：在5楼附件里，我加了一列，代码运行错误显示'13'，怎样修改?