关于工作年限的计算

海阔天空12

公式还有些问题，请各位完善一下

sunya_0529

用自定义函数做，效果如下——


自定义函数的代码如下——

1. Option Explicit
   
2. 
   
3. Function SumMonths(rngCritera As Range, rngData As Range)
   
4. Dim datStart As Date, datEnd As Date, strTemp$, k As Range, d1 As Date, d2 As Date
   
5. If InStr(rngCritera.Value, "至") > 0 Then
   
6.   datStart = CDate(RegTest(rngCritera.Value, "\d{4}年\d+月\d+日", 0))
   
7.   datEnd = CDate(RegTest(rngCritera.Value, "\d{4}年\d+月\d+日", 1))
   
8. ElseIf InStr(rngCritera.Value, "前") > 0 Or InStr(rngCritera.Value, "底") > 0 Then
   
9.   datStart = DateSerial(1900, 1, 1)
   
10.   strTemp = RegTest(rngCritera.Value, "(\d{4}年\d+月\d+日.)|(\d{4}年后)|(\d{4}年\d+月.)", 0)
    
11.   strTemp = Replace(strTemp, "月底", "月28日底")
    
12.   strTemp = Replace(strTemp, "月前", "月28日前")
    
13.   datEnd = CDate(Left(strTemp, Len(strTemp) - 1))
    
14. ElseIf InStr(rngCritera.Value, "后") > 0 Then
    
15.   strTemp = RegTest(rngCritera.Value, "(\d{4}年\d+月\d+日后)|(\d{4}年后)|(\d{4}年\d+月后)", 0)
    
16.   strTemp = Replace(strTemp, "年后", "年1月1日后")
    
17.   datStart = CDate(Left(strTemp, Len(strTemp) - 1))
    
18.   datEnd = Date
    
19. End If
    
20. If Day(datStart) > 1 Then datStart = DateSerial(Year(datStart), Month(datStart) + 1, 1)
    
21. If Day(datEnd) > 1 Then datEnd = DateSerial(Year(datEnd), Month(datEnd) + 1, 1)
    
22. For Each k In rngData.Columns(1).Cells
    
23.   If Len(k.Value) > 0 Then
    
24.     d1 = Application.Max(datStart, CDate(Format(k.Value, "0000年00月")))
    
25.     d2 = Application.Min(datEnd, DateAdd("m", 1, CDate(Format(k.Offset(0, 1).Value, "0000年00月"))))
    
26.     SumMonths = SumMonths + IIf(d1 < d2, DateDiff("m", d1, d2), 0)
    
27.   End If
    
28. Next
    
29. End Function
    
30. 
    
31. Function RegTest(strText As String, strPattern As String, intItem As Integer)
    
32. '定义正则表达式对象
    
33. Dim oRegExp As Object
    
34. '定义匹配字符串集合对象
    
35. Dim oMatches As Object
    
36. '创建正则表达式
    
37. Set oRegExp = CreateObject("vbscript.regexp")
    
38. With oRegExp
    
39.   '设置是否匹配所有的符合项，True表示匹配所有, False表示仅匹配第一个符合项
    
40.   .Global = True
    
41.   '设置是否区分大小写，True表示不区分大小写, False表示区分大小写
    
42.   .IgnoreCase = True
    
43.   '设置要查找的字符模式
    
44.   .Pattern = strPattern
    
45.   '对字符串执行正则查找，返回所有的查找值的集合，若未找到，则为空
    
46.   Set oMatches = .Execute(strText)
    
47.   RegTest = oMatches(intItem)
    
48. End With
    
49. Set oRegExp = Nothing
    
50. Set oMatches = Nothing
    
51. End Function

复制代码