合并连续日期

ykcbf1100

附件供参考。。。

ykcbf1100

代码供参考。。。

1. Sub ykcbf()   '//2024.2.20
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("日期展开")
   
6.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
   
7.         arr = .[a1].Resize(r, 3)
   
8.     End With
   
9.     On Error Resume Next
   
10.     ReDim brr(1 To UBound(arr), 1 To 5)
    
11.     For i = 2 To UBound(arr)
    
12.         s = arr(i, 2) & "|" & arr(i, 1)
    
13.         rq = Format(arr(i, 3), "yyyy-m-d")
    
14.         If Not d.exists(s) Then
    
15.             d(s) = rq
    
16.         Else
    
17.             d(s) = IIf(InStr(d(s), rq), d(s), d(s) & "、" & rq)
    
18.         End If
    
19.     Next
    
20.     For Each k In d.keys
    
21.         m = m + 1
    
22.         brr(m, 1) = Split(k, "|")(0)
    
23.         brr(m, 4) = Split(k, "|")(1)
    
24.         t = Split(d(k), "、")
    
25.         st = t(0)
    
26.         For x = 1 To UBound(t)
    
27.             If CLng(DateValue(t(x))) - CLng(DateValue(t(x - 1))) = 1 Then
    
28.                 If x = t(UBound(t)) Or CLng(DateValue(t(x + 1))) - CLng(DateValue(t(x))) <> 1 Then
    
29.                     st = st & "至" & Format(t(x), "yyyy-m-d")
    
30.                 End If
    
31.             Else
    
32.                 st = st & "、" & Format(t(x), "yyyy-m-d")
    
33.             End If
    
34.         Next
    
35.         brr(m, 5) = st
    
36.     Next
    
37.     With Sheets("日期汇总")
    
38.         .UsedRange.Offset(1).Clear
    
39.         .Columns(1).NumberFormatLocal = "@"
    
40.         With .[a2].Resize(m, 5)
    
41.             .Value = brr
    
42.             .Borders.LineStyle = 1
    
43.             .HorizontalAlignment = xlCenter
    
44.             .VerticalAlignment = xlCenter
    
45.             .EntireColumn.AutoFit
    
46.         End With
    
47.     End With
    
48.     Set d = Nothing
    
49.     Application.ScreenUpdating = True
    
50.     MsgBox "OK！"
    
51. End Sub
    

复制代码

chenxuefu

yynrzwh 发表于 2024-2-20 11:30

太酷，谢谢大佬

chenxuefu

明天会更好zj 发表于 2024-2-20 11:11

新方法，谢谢大佬

chenxuefu

半百 发表于 2024-2-20 11:04
请测试

经典，谢谢大佬

chenxuefu

ykcbf1100 发表于 2024-2-20 13:55
代码供参考。。。

专业，大佬谢谢

飞天篮球猪

百花齐放，供参考...

chenxuefu

新函数111111111111111