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

shi353

看附件可以知道我想要的結果，煩請各位先進幫忙
，謝謝!

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.       rq = Day(arr(i, 2))
    
11.       If Not d.Exists(arr(i, 1)) Then
    
12.         Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
13.       End If
    
14.       For k = 3 To 4
    
15.         If arr(i, k) = "V" Then
    
16.           If Not d(arr(i, 1)).Exists(k) Then
    
17.             m = 1
    
18.             ReDim brr(1 To m)
    
19.           Else
    
20.             brr = d(arr(i, 1))(k)
    
21.             m = UBound(brr) + 1
    
22.             ReDim Preserve brr(1 To m)
    
23.           End If
    
24.           brr(m) = Day(arr(i, 2))
    
25.           d(arr(i, 1))(k) = brr
    
26.         End If
    
27.       Next
    
28.     Next
    
29.     For Each aa In d.Keys
    
30.       For Each bb In d(aa).Keys
    
31.         brr = d(aa)(bb)
    
32.         For i = 1 To UBound(brr) - 1
    
33.           p = i
    
34.           For j = i + 1 To UBound(brr)
    
35.             If brr(p) > brr(j) Then
    
36.               p = j
    
37.             End If
    
38.           Next
    
39.           If p <> i Then
    
40.             temp = brr(i)
    
41.             brr(i) = brr(p)
    
42.             brr(p) = temp
    
43.           End If
    
44.           d(aa)(bb) = brr
    
45.         Next
    
46.       Next
    
47.     Next
    
48.    
    
49.     For Each aa In d.Keys
    
50.       ss = ""
    
51.       For Each bb In d(aa).Keys
    
52.         ss = ss & Chr(32) & IIf(bb = 3, "中", "晚") & "/" & Join(d(aa)(bb), ",")
    
53.       Next
    
54.       d(aa) = Mid(ss, 2)
    
55.     Next
    
56.     .Range("g2").Resize(d.Count, 2) = Application.Transpose(Array(d.Keys, d.Items))
    
57.   End With
    
58.       
    
59.       
    
60. End Sub
    

复制代码

chxw68

参见附件。

shi353

謝謝!  我要好好研究一下多多學習字典的用法了

liulang0808

1. Sub 按钮7_Click()
   
2.     Application.ScreenUpdating = False
   
3.     arr = ActiveSheet.UsedRange
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     Set d2 = CreateObject("scripting.dictionary")
   
6.     Set d3 = CreateObject("scripting.dictionary")
   
7.     Dim brr() As Integer
   
8.     For j = 2 To UBound(arr)
   
9.         d3(arr(j, 1)) = ""
   
10.         If arr(j, 3) = "V" Then
    
11.             If d1.exists(arr(j, 1)) Then
    
12.                 d1(arr(j, 1)) = d1(arr(j, 1)) & "," & Day(arr(j, 2))
    
13.             Else
    
14.                 d1(arr(j, 1)) = Day(arr(j, 2))
    
15.             End If
    
16.         End If
    
17.         
    
18.         If arr(j, 4) = "V" Then
    
19.             If d2.exists(arr(j, 1)) Then
    
20.                 d2(arr(j, 1)) = d2(arr(j, 1)) & "," & Day(arr(j, 2))
    
21.             Else
    
22.                 d2(arr(j, 1)) = Day(arr(j, 2))
    
23.             End If
    
24.         End If
    
25.     Next j
    
26.     [g2].Resize(d3.Count) = WorksheetFunction.Transpose(d3.keys)
    
27.     r = Cells(Rows.Count, "g").End(3).Row
    
28.     arr = Range("g1:h" & r)
    
29.     For j = 2 To r
    
30.         If d1.exists(arr(j, 1)) Then
    
31.             If InStr(d1(arr(j, 1)), ",") = 0 Then
    
32.                 str1 = "中/" & d1(arr(j, 1))
    
33.             Else
    
34.                 crr = Split(d1(arr(j, 1)), ",")
    
35.                 ReDim brr(0 To UBound(crr))
    
36.                 For m = 0 To UBound(crr)
    
37.                     brr(m) = Val(crr(m)) * 1
    
38.                 Next m
    
39.                 str1 = "中/"
    
40.                 str2 = ""
    
41.                 For k = 0 To UBound(brr)
    
42. 
    
43.                     str2 = str2 & "," & WorksheetFunction.Small(brr, k + 1)
    
44.                 Next k
    
45.                 str1 = str1 & Right(str2, Len(str2) - 1)
    
46.             End If
    
47.             
    
48.             If d2.exists(arr(j, 1)) Then
    
49.                 If InStr(d2(arr(j, 1)), ",") > 0 Then
    
50.                     str11 = "■夜/" & d2(arr(j, 1))
    
51.                 Else
    
52.                     crr = Split(d1(arr(j, 1)), ",")
    
53.                     ReDim brr(0 To UBound(crr))
    
54.                     For m = 0 To UBound(crr)
    
55.                         brr(m) = Val(crr(m)) * 1
    
56.                     Next m
    
57.                     str11 = "■夜/"
    
58.                     str21 = ""
    
59.                     For k = 0 To UBound(brr)
    
60.                         str21 = str21 & "," & WorksheetFunction.Small(brr, k + 1)
    
61.                     Next k
    
62.                     str11 = str11 & Right(str21, Len(str21) - 1)
    
63.                     
    
64.                 End If
    
65.                 str1 = str1 & str11
    
66.             End If
    
67.             
    
68.         Else
    
69.             If d2.exists(arr(j, 1)) Then
    
70.                 If InStr(d2(arr(j, 1)), ",") > 0 Then
    
71.                     str1 = "■夜/" & d2(arr(j, 1))
    
72.                 Else
    
73.                     crr = Split(d1(arr(j, 1)), ",")
    
74.                     ReDim brr(0 To UBound(crr))
    
75.                     For m = 0 To UBound(crr)
    
76.                         brr(m) = Val(crr(m)) * 1
    
77.                     Next m
    
78.                     str1 = "夜/"
    
79.                     str2 = ""
    
80.                     For k = 0 To UBound(brr)
    
81.                         str2 = str2 & "," & WorksheetFunction.Small(brr, k + 1)
    
82.                     Next k
    
83.                     str1 = str1 & Right(str2, Len(str2) - 1)
    
84.                 End If
    
85.             End If
    
86.         End If
    
87.         arr(j, 2) = str1
    
88.     Next j
    
89.     Range("g1:h" & r) = arr
    
90.     Application.ScreenUpdating = True
    
91. End Sub

复制代码

liulang0808

看看是否满足需求吧

bluexuemei

1. Sub t()
   
2. Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript": ojs.timeout = -1
   
3. y = ojs.eval("def aa(aa);$aa=aa;end")
   
4. y = ojs.Run("aa", Sheet1.Range("a2:d" & Sheet1.[a2].End(4).Row).Value)
   
5. y = ojs.eval("h1=Hash.new{[]};h2=Hash.new{[]};$aa.each{|x|if x[2].size!=0;h1[x[0]]<<=x[1].split('/')[-1];end;if x[3].size!=0;h2[x[0]]<<=x[1].split('/')[-1];end};$aa.map{|x|x[0]}.uniq.map{|x|[x,((h1[x]!=[]?('中/'+h1[x].join(',')):'') +10.chr+(h2[x]!=[]?('夜/'+h2[x].join(',')):''))[/.+\s?.+/]]}")
   
6. Sheet1.[r2].Resize(UBound(y) + 1, 2) = y
   
7. Set ojs = Nothing
   
8. 'Stop
   
9. End Sub
   

复制代码

zax010

Sub zz()
    Dim d1, d2, d3, arr, n
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    Set d3 = CreateObject("Scripting.Dictionary")
    lr = [a65536].End(3).Row
    Range("A1:D" & lr).Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess
    arr = [a1].CurrentRegion
    For i = 2 To UBound(arr)
        d3(arr(i, 1)) = ""
        If arr(i, 3) <> "" Then d1(arr(i, 1)) = d1(arr(i, 1)) & "," & Day(arr(i, 2))
        If arr(i, 4) <> "" Then d2(arr(i, 1)) = d2(arr(i, 1)) & "," & Day(arr(i, 2))
    Next
    For Each k In d3.keys
        Cells(2 + n, "g") = k
        Cells(2 + n, "h") = "中/" & Mid(d1(k), 2) & "■" & "夜/" & Mid(d2(k), 2)
        n = n + 1
    Next
End Sub

yjh_27

参见附件。

zax010

>>>>>>>>>>>>>>>>>>>>>>>>>
test1.rar (11.35 KB, 下载次数: 4)

2014-12-9 22:48 上传

点击文件名下载附件