把对应日期的数据自动填入

7993708

feilanga 发表于 2024-5-21 16:29
.................

老师，非常好用，就是能不能   字母不区分大小写 ，麻烦一下，感谢

ykcbf1100

7993708 发表于 2024-5-21 16:24
老师，其它没问题，怎么不区分大小写? 感谢

改好了。。。

你原附件上是没有大小写问题的。

feilanga

7993708 发表于 2024-5-21 16:35
老师，非常好用，就是能不能   字母不区分大小写 ，麻烦一下，感谢

建议认真看回复。第二个回复就是不区分

quqiyuan

参与一下，供参考

quqiyuan

代码上传

1. Sub test()
   
2.     Set sht = ThisWorkbook.Sheets("每日数据")
   
3.     Set sh1 = ThisWorkbook.Sheets("原表")
   
4.     arr = sht.UsedRange
   
5.     brr = sh1.UsedRange
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     For i = 3 To UBound(arr)
   
8.         s = UCase(arr(i, 2)) & arr(i, 3)
   
9.         If s <> "" Then d(s) = i
   
10.     Next
    
11.     ReDim crr(1 To UBound(arr) - 2, 1 To 31)
    
12.     For i = 3 To UBound(brr)
    
13.         For j = 1 To 2
    
14.             If j = 1 Then
    
15.                 s = UCase(brr(i, 3)) & brr(i, 5)
    
16.                 d1 = Day(brr(i, 1))
    
17.                 sums = brr(i, 6)
    
18.             Else
    
19.                 s = UCase(brr(i, 12)) & brr(i, 19)
    
20.                 d1 = Day(brr(i, 11))
    
21.                 sums = brr(i, 13)
    
22.             End If
    
23.             If s <> "" Then crr(d(s) - 2, d1) = crr(d(s) - 2, d1) + sums
    
24.         Next
    
25.     Next
    
26.     sht.[n3].Resize(UBound(crr), 31) = crr
    
27.     Set d = Nothing
    
28. End Sub
    

复制代码

feilanga

1. Sub cx()
   
2.     arr = Sheet4.Range("A1:I" & Sheet4.Cells(Rows.Count, "A").End(xlUp).Row)
   
3.     arr2 = Sheet4.Range("k1:t" & Sheet4.Cells(Rows.Count, "k").End(xlUp).Row)
   
4.     Dim dic As Object
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.     For i = 3 To UBound(arr)
   
7.         If InStr(arr(i, 1), ".") > 0 Then
   
8.             rq = CStr(Day(CDate(Replace(arr(i, 1), ".", "-"))))
   
9.         Else
   
10.             rq = CStr(Day(arr(i, 1)))
    
11.         End If
    
12.         Key = UCase(arr(i, 3)) & "," & UCase(arr(i, 5))
    
13.         If Not dic.exists(Key) Then
    
14.             Set dic(Key) = CreateObject("scripting.dictionary")
    
15.         End If
    
16.         dic(Key)(rq) = dic(Key)(rq) + arr(i, 6)
    
17.     Next
    
18.     For i = 3 To UBound(arr2)
    
19.         If InStr(arr2(i, 1), ".") > 0 Then
    
20.             rq = CStr(Day(CDate(Replace(arr2(i, 1), ".", "-"))))
    
21.         Else
    
22.             rq = CStr(Day(arr2(i, 1)))
    
23.         End If
    
24.         Key = UCase(arr2(i, 2)) & "," & UCase(arr2(i, 9))
    
25.         If Not dic.exists(Key) Then
    
26.             Set dic(Key) = CreateObject("scripting.dictionary")
    
27.         End If
    
28.         dic(Key)(rq) = dic(Key)(rq) + arr2(i, 3)
    
29.     Next
    
30.     Keys = dic.Keys
    
31.     items = dic.items
    
32.     ReDim my(1 To dic.Count, 1 To 2)
    
33.     For i = 0 To UBound(Keys)
    
34.         s = Keys(i)
    
35.         k = k + 1
    
36.         my(k, 1) = Split(s, ",")(0)
    
37.         my(k, 2) = Split(s, ",")(1)
    
38.     Next
    
39.     Sheet1.Range("B3").Resize(k, 2).ClearContents
    
40.     Sheet1.Range("B3").Resize(k, 2) = my
    
41.     Sheet1.Range("M3").Resize(k, 1).ClearContents
    
42.     Sheet1.[m3].Resize(UBound(my), 1) = Application.Index(my, 0, 2)
    
43.     dr = Sheet1.Range("N1:AR" & Sheet1.Cells(Rows.Count, "B").End(xlUp).Row)
    
44.     ReDim brr(1 To UBound(my), 1 To 31)
    
45.     k = 0
    
46.     For i = 1 To UBound(my)
    
47.         If my(i, 1) <> "" Then
    
48.             k = k + 1
    
49.             s = my(i, 1) & "," & my(i, 2)
    
50.             For j = 1 To UBound(dr, 2)
    
51.                 ss = CStr(dr(2, j))
    
52.                 If dic.exists(s) Then
    
53.                     brr(k, j) = dic(s)(ss)
    
54.                 End If
    
55.             Next
    
56.         End If
    
57.     Next
    
58.     Sheet1.Range("n3:AR" & Rows.Count).ClearContents
    
59.     Sheet1.Range("N3").Resize(k, 31) = brr
    
60. End Sub
    
61. 
    

复制代码

7993708

feilanga 发表于 2024-5-21 17:21
建议认真看回复。第二个回复就是不区分

老师，有看到，功能都OK，已上了小花，就是原表不能有空行，有空行数据就乱了。谢谢你

7993708

feilanga 发表于 2024-5-21 17:21
建议认真看回复。第二个回复就是不区分

有看到，谢谢老师，就是不能有空行。其它没问题

7993708

quqiyuan 发表于 2024-5-21 17:23
参与一下，供参考

老师您好，字母大小写有问题。

quqiyuan

7993708 发表于 2024-5-21 19:18
老师您好，字母大小写有问题。

两个关键字都加了ucase了，一开始我以为是第一个用了就可以