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

7993708 · 发表于 2024-5-21 16:35

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

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

ykcbf1100 · 发表于 2024-5-21 16:43

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

改好了。。。

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

feilanga · 发表于 2024-5-21 17:21

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

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

quqiyuan · 发表于 2024-5-21 17:23

参与一下，供参考

quqiyuan · 发表于 2024-5-21 17:24

代码上传

Sub test()
Set sht = ThisWorkbook.Sheets("每日数据")
Set sh1 = ThisWorkbook.Sheets("原表")
arr = sht.UsedRange
brr = sh1.UsedRange
Set d = CreateObject("scripting.dictionary")
For i = 3 To UBound(arr)
s = UCase(arr(i, 2)) & arr(i, 3)
If s <> "" Then d(s) = i
Next
ReDim crr(1 To UBound(arr) - 2, 1 To 31)
For i = 3 To UBound(brr)
For j = 1 To 2
If j = 1 Then
s = UCase(brr(i, 3)) & brr(i, 5)
d1 = Day(brr(i, 1))
sums = brr(i, 6)
Else
s = UCase(brr(i, 12)) & brr(i, 19)
d1 = Day(brr(i, 11))
sums = brr(i, 13)
End If
If s <> "" Then crr(d(s) - 2, d1) = crr(d(s) - 2, d1) + sums
Next
Next
sht.[n3].Resize(UBound(crr), 31) = crr
Set d = Nothing
End Sub

复制代码

feilanga · 发表于 2024-5-21 17:28

Sub cx()
arr = Sheet4.Range("A1:I" & Sheet4.Cells(Rows.Count, "A").End(xlUp).Row)
arr2 = Sheet4.Range("k1:t" & Sheet4.Cells(Rows.Count, "k").End(xlUp).Row)
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
For i = 3 To UBound(arr)
If InStr(arr(i, 1), ".") > 0 Then
rq = CStr(Day(CDate(Replace(arr(i, 1), ".", "-"))))
Else
rq = CStr(Day(arr(i, 1)))
End If
Key = UCase(arr(i, 3)) & "," & UCase(arr(i, 5))
If Not dic.exists(Key) Then
Set dic(Key) = CreateObject("scripting.dictionary")
End If
dic(Key)(rq) = dic(Key)(rq) + arr(i, 6)
Next
For i = 3 To UBound(arr2)
If InStr(arr2(i, 1), ".") > 0 Then
rq = CStr(Day(CDate(Replace(arr2(i, 1), ".", "-"))))
Else
rq = CStr(Day(arr2(i, 1)))
End If
Key = UCase(arr2(i, 2)) & "," & UCase(arr2(i, 9))
If Not dic.exists(Key) Then
Set dic(Key) = CreateObject("scripting.dictionary")
End If
dic(Key)(rq) = dic(Key)(rq) + arr2(i, 3)
Next
Keys = dic.Keys
items = dic.items
ReDim my(1 To dic.Count, 1 To 2)
For i = 0 To UBound(Keys)
s = Keys(i)
k = k + 1
my(k, 1) = Split(s, ",")(0)
my(k, 2) = Split(s, ",")(1)
Next
Sheet1.Range("B3").Resize(k, 2).ClearContents
Sheet1.Range("B3").Resize(k, 2) = my
Sheet1.Range("M3").Resize(k, 1).ClearContents
Sheet1.[m3].Resize(UBound(my), 1) = Application.Index(my, 0, 2)
dr = Sheet1.Range("N1:AR" & Sheet1.Cells(Rows.Count, "B").End(xlUp).Row)
ReDim brr(1 To UBound(my), 1 To 31)
k = 0
For i = 1 To UBound(my)
If my(i, 1) <> "" Then
k = k + 1
s = my(i, 1) & "," & my(i, 2)
For j = 1 To UBound(dr, 2)
ss = CStr(dr(2, j))
If dic.exists(s) Then
brr(k, j) = dic(s)(ss)
End If
Next
End If
Next
Sheet1.Range("n3:AR" & Rows.Count).ClearContents
Sheet1.Range("N3").Resize(k, 31) = brr
End Sub

复制代码

7993708 · 发表于 2024-5-21 19:09

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

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

7993708 · 发表于 2024-5-21 19:10

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

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

7993708 · 发表于 2024-5-21 19:18

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

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

quqiyuan · 发表于 2024-5-21 19:24

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

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

		自动登录	找回密码
密码			免费注册

[已解决] 把对应日期的数据自动填入

评分

评分