如何將各人員的中班夜班的日期由小到大排序彙整出來

YZC51

留下脚印，回头再来细细学习

shi353

我想把各日期都集中，夜班的有底線且變藍色，不知道各位先進可否再幫忙解出vba做法

chxw68

1. Sub test()
   
2.   Dim d As Object
   
3.   Dim r%, i%
   
4.   Dim arr, brr
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:d" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       For j = 3 To 4
    
11.         If Len(arr(i, j)) <> 0 Then
    
12.           If Not d.Exists(arr(i, 1)) Then
    
13.             m = 1
    
14.             ReDim brr(1 To 2, 1 To m)
    
15.           Else
    
16.             brr = d(arr(i, 1))
    
17.             m = UBound(brr, 2) + 1
    
18.             ReDim Preserve brr(1 To 2, 1 To m)
    
19.           End If
    
20.           brr(1, m) = Day(arr(i, 2))
    
21.           brr(2, m) = j
    
22.           d(arr(i, 1)) = brr
    
23.         End If
    
24.       Next
    
25.     Next
    
26.   End With
    
27.   For Each aa In d.Keys
    
28.     brr = d(aa)
    
29.     For i = 1 To UBound(brr, 2) - 1
    
30.       p = i
    
31.       For j = i + 1 To UBound(brr, 2)
    
32.         If brr(1, p) > brr(1, j) Then
    
33.           p = j
    
34.         End If
    
35.       Next
    
36.       If p <> i Then
    
37.         temp1 = brr(1, i)
    
38.         temp2 = brr(2, i)
    
39.         brr(1, i) = brr(1, p)
    
40.         brr(2, i) = brr(2, p)
    
41.         brr(1, p) = temp1
    
42.         brr(2, p) = temp2
    
43.       End If
    
44.     Next
    
45.     d(aa) = brr
    
46.   Next
    
47.   m = 2
    
48.   With Worksheets("sheet1")
    
49.     For Each aa In d.Keys
    
50.       arr = Application.Index(d(aa), 2, 0)
    
51.       brr = Application.Index(d(aa), 1, 0)
    
52.       ReDim crr(0 To UBound(brr))
    
53.       s = 1
    
54.       For i = 1 To UBound(brr)
    
55.         crr(i) = s
    
56.         s = s + Len(brr(i)) + 1
    
57.       Next
    
58.       .Cells(m, 7) = aa
    
59.       .Cells(m, 8) = Join(brr, ",")
    
60.       For i = 1 To UBound(brr)
    
61.         If arr(i) = 4 Then
    
62.           With .Cells(m, 8).Characters(Start:=crr(i), Length:=Len(brr(i)) + 1).Font
    
63.             .Underline = xlUnderlineStyleSingle
    
64.             .ColorIndex = 5
    
65.           End With
    
66.         End If
    
67.       Next
    
68.       m = m + 1
    
69.     Next
    
70.   End With
    
71.   tt = d.Items
    
72. End Sub

复制代码

chxw68

很少做这样的题，还是有一些挑战性的。

shi353

謝謝花費心思想出宏碼!
有時間再慢慢研究了!