怎样按日期实现记录中的班组时间顺序

b12b3bb

怎样按日期实现记录中的班组时间顺序, 谢谢！

班组顺序.rar (2.62 KB, 下载次数: 18)

2016-10-2 16:19 上传

点击文件名下载附件

lsc900707

数据排序可以搞定呀。。。。。。

b12b3bb

数据太多。而且不用表格

b12b3bb

数据太多。而且不同表格

wzsy2_mrf

1. Option Explicit
   
2. Sub test()
   
3.     Dim r%, i%, j&, arr, brr, n%, d, mkey, mItems, xm$
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     r = Cells(Rows.Count, 1).End(xlUp).Row
   
6.     arr = Range("a2:c" & r)
   
7.     ReDim brr(1 To UBound(arr), 1 To 100)
   
8.     For i = 1 To UBound(arr)
   
9.         xm = arr(i, 1)
   
10.         If Not d.exists(xm) Then
    
11.             d(xm) = arr(i, 3)
    
12.         Else
    
13.             If InStr(d(xm), arr(i, 3)) = 0 Then d(xm) = d(xm) & "++" & arr(i, 3)
    
14.         End If
    
15.     Next
    
16.     For Each mkey In d.keys
    
17.         mItems = Split(d(mkey), "++")
    
18.         j = j + 1
    
19.         brr(j, 1) = mkey
    
20.         For i = 0 To UBound(mItems)
    
21.             brr(j, i + 2) = mItems(i)
    
22.         Next
    
23.     Next
    
24.    
    
25.     Range("f2").Resize(UBound(brr), UBound(brr, 2)).Clear
    
26.     Range("f2").Resize(j, i + 1) = brr
    
27.     Range("f2").Resize(j, i + 1).Borders.LineStyle = xlContinuous
    
28.     Erase arr, brr: Set d = Nothing
    
29. End Sub
    

复制代码

wzsy2_mrf

以上代码放在sheet1表，要求事先按时间有序。

b12b3bb

wzsy2_mrf 发表于 2016-10-2 16:50

谢谢！我要的是 单元格中的日期选择后显示当天的班组顺序。

duquancai

1. Sub shishi()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set d1 = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     r = Cells(Rows.Count, 1).End(3).Row
   
6.     arr = Range("a3:c" & r - 1)
   
7.     For x = 1 To UBound(arr)
   
8.         d(CStr(arr(x, 1))) = d(CStr(arr(x, 1))) & arr(x, 3) & "|"
   
9.     Next
   
10.     k = d.keys: ite = d.items
    
11.     For i = 1 To d.Count
    
12.         Range("f10")(i, 1).Resize(1, 1) = k(i - 1)
    
13.         n = Split(ite(i - 1), "|")
    
14.         For y = 0 To UBound(n)
    
15.             d1(n(y)) = ""
    
16.         Next
    
17.         Range("g10")(i, 1).Resize(1, d1.Count) = d1.keys
    
18.         d1.RemoveAll
    
19.     Next
    
20.     Application.ScreenUpdating = True
    
21. End Sub

复制代码

wzsy2_mrf

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Target.Address = "$F$2" Then
   
3.         Dim r%, i%, arr, brr, n%, d, mkey, mItems, xm$
   
4.         Set d = CreateObject("scripting.dictionary")
   
5.         r = Cells(Rows.Count, 1).End(xlUp).Row
   
6.         arr = Range("a2:c" & r)
   
7.         ReDim brr(1 To 1, 1 To 100)
   
8.         For i = 1 To UBound(arr)
   
9.             xm = arr(i, 1) & ""
   
10.             If Not d.exists(xm) Then
    
11.                 d(xm) = arr(i, 3)
    
12.             Else
    
13.                 If InStr(d(xm), arr(i, 3)) = 0 Then d(xm) = d(xm) & "++" & arr(i, 3)
    
14.             End If
    
15.         Next
    
16.         
    
17.         With Range("f2").Validation
    
18.             .Delete
    
19.             .Add 3, 1, 1, Join(d.keys, ",")
    
20.             
    
21.         End With
    
22.         
    
23.         xm = d(Range("F2").Value & "")
    
24.         mItems = Split(xm, "++")
    
25.         For i = 0 To UBound(mItems)
    
26.             brr(1, i + 1) = mItems(i)
    
27.         Next
    
28.         Range("G2").Resize(1, 100).ClearContents
    
29.         Range("G2").Resize(1, i) = brr
    
30.         Erase arr, brr: Set d = Nothing
    
31.     End If
    
32. End Sub
    

复制代码

b12b3bb

wzsy2_mrf 发表于 2016-10-2 17:26

问题解决了。衷心感谢！！！