请教老师：如何查找相同日期所对应的编号？

zainan0810

不知道为什么 发表于 2018-8-4 13:06
刚开电脑。代码如下

再次谢谢不知道为什么老师对我的悉心指教！您的汗水我收下了。

zainan0810

不知道为什么 发表于 2018-8-4 13:06
刚开电脑。代码如下

不知道为什么老师，代码少了一部分。麻烦有空再补下啊，谢谢！

不知道为什么

zainan0810 发表于 2018-8-5 13:45
不知道为什么老师，代码少了一部分。麻烦有空再补下啊，谢谢！

补上

1. Option Explicit
   
2. Sub 结果N()
   
3.     Dim Dic, Dfh, Djs, Arr, Brr(), k, Msg
   
4.     Dim Ms$, Mm$, Gjz$, i&, j&, n&, x&, y&, bz%
   
5.     Dim crr(1 To 10000)
   
6.     Application.ScreenUpdating = False
   
7.     Set Dic = CreateObject("scripting.dictionary")
   
8.     Set Dfh = CreateObject("scripting.dictionary")
   
9.     With Sheets("种类")
   
10.         Arr = .[a1].CurrentRegion
    
11.         For i = 1 To UBound(Arr)
    
12.             Ms = Trim(Arr(i, 2)) & "|" & Trim(Arr(i, 3)) & "|" & Trim(Arr(i, 4))
    
13.             Dfh(Ms) = Arr(i, 1)
    
14.         Next i
    
15.     End With
    
16.     With Sheets("原始数据")
    
17.         Arr = .[a1].CurrentRegion
    
18.         For i = 2 To UBound(Arr)
    
19.             Gjz = CStr(Trim(Arr(i, 1))) & "#" & CStr(DateValue(Arr(i, 2)))
    
20.             Ms = Trim(Arr(i, 3)) & "|" & Trim(Arr(i, 4)) & "|" & Trim(Arr(i, 5))
    
21.             Dic(Gjz) = Dic(Gjz) & "#" & Ms
    
22.         Next i
    
23.     End With
    
24.     ReDim Brr(1 To Dic.Count + 1, 1 To 500)
    
25.     For Each k In Dic.keys
    
26.         y = 2
    
27.         x = x + 1
    
28.         Brr(x, 1) = Split(k, "#")(0): Brr(x, 2) = Split(k, "#")(1)
    
29.         Ms = Right(Dic(k), Len(Dic(k)) - 1)
    
30.         Msg = Split(Ms, "#")
    
31.         Set Djs = CreateObject("scripting.dictionary")
    
32.         For i = 0 To UBound(Msg)
    
33.             Mm = Msg(i)
    
34.             y = y + 1
    
35.             Djs(Mm) = Djs(Mm) + 1
    
36.             bz = Djs(Mm) - 1
    
37.             'If bz = 0 Then
    
38.                ' Brr(x, y) = CStr(Dfh(Mm))
    
39.             'Else
    
40.                ' Brr(x, y) = CStr(Dfh(Mm) & "." & bz)
    
41.             'End If
    
42.             Brr(x, y) = IIf(bz = 0, CStr(Dfh(Mm)), CStr(Dfh(Mm) & "." & bz))
    
43.         Next i
    
44.         j = j + 1
    
45.         crr(j) = y
    
46.     Next
    
47.     n = WorksheetFunction.Max(crr)
    
48.     With Sheets("结果")
    
49.         .Cells.Clear
    
50.         .[a1].Resize(Dic.Count, n) = Brr
    
51.         .Activate
    
52.     End With
    
53.     Set Dic = Nothing: Set Dfh = Nothing: Set Djs = Nothing
    
54.     Application.ScreenUpdating = True
    
55. End Sub
    

复制代码

zainan0810

不知道为什么 发表于 2018-8-5 15:25
补上

不知道为什么老师，结果中，日期好像不对了，请您有空再看下呗。

不知道为什么

zainan0810 发表于 2018-8-5 15:42
不知道为什么老师，结果中，日期好像不对了，请您有空再看下呗。

你把有问题的附件传上来看看，我这里运行都ok的

zainan0810

不知道为什么 发表于 2018-8-5 18:06
你把有问题的附件传上来看看，我这里运行都ok的

每天日月年的种类横向组合.rar (402.46 KB, 下载次数: 2)

2018-8-6 21:00 上传

点击文件名下载附件

请老师您有空受累看下！在“结果”的B列，日期我这里不对了。请您解惑！

不知道为什么

zainan0810 发表于 2018-8-6 21:01
请老师您有空受累看下！在“结果”的B列，日期我这里不对了。请您解惑！

没看出哪里错啊？

zainan0810

不知道为什么 发表于 2018-8-6 21:05
没看出哪里错啊？

zainan0810

不知道为什么 发表于 2018-8-6 21:05
没看出哪里错啊？

出现2020年的啦，我也不知为什么了。

zainan0810

不知道为什么 发表于 2018-8-6 21:05
没看出哪里错啊？

看来肯定是我这里出错了，可不知差哪儿啦。