字典填数据

小鼠爱大米

想把SAPH表中D列 对应填入到（根据工号和日期） 人事H表中的G列

麻烦问下，程序为啥不能显示结果？

yynrzwh

Sub step3_reconcile()
Dim d As Object, arr, brr, r As Integer, i As Integer
Set d = CreateObject("scripting.dictionary")
r = Sheets("SAPH").Cells(Rows.Count, 1).End(3).Row
arr = Sheets("SAPH").Range("a3:d" & r)
For i = 1 To UBound(arr)
    s = arr(i, 1) & arr(i, 3)
    d(s) = arr(i, 4)
Next
r2 = Sheets("人事H").Cells(Rows.Count, 1).End(3).Row
brr = Sheets("人事H").Range("a3:G" & r2)
For i = 1 To UBound(brr)
    If d.exists(brr(i, 1) & brr(i, 4)) Then
        brr(i, 7) = d(brr(i, 1) & brr(i, 4))
    End If
Next
Sheets("人事H").Range("g3:G" & r2).ClearContents
Sheets("人事H").Range("a3:G" & r2) = brr
End Sub

romecyf

Sub step3_reconcile()

Dim d As Object, arr, brr, r As Integer, i As Integer
Set d = CreateObject("scripting.dictionary")
r = Sheets("SAPH").Cells(Rows.Count, 1).End(3).Row
arr = Sheets("SAPH").Range("a3:d" & r)

For i = 1 To UBound(arr)
  s = arr(i, 1) & arr(i, 3)

d(s) = arr(i, 4)

Next

r2 = Sheets("人事H").Cells(Rows.Count, 1).End(3).Row
brr = Sheets("人事H").Range("a3:G" & r2)


For i = 1 To UBound(brr)
   If d.exists(brr(i, 1) & brr(i, 4)) Then
   Sheets("人事H").Cells(i + 2, 7).Value = d(brr(i, 1) & brr(i, 4))
   End If
Next

End Sub

taller

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("SAPH")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         arr = .Range("a3:d" & r)
   
9.         For i = 1 To UBound(arr)
   
10.             xm = arr(i, 1) & "+" & arr(i, 3)
    
11.             d(xm) = arr(i, 4)
    
12.         Next
    
13.     End With
    
14.     With Worksheets("人事H")
    
15.         .AutoFilterMode = False
    
16.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
17.         arr = .Range("a3:g" & r)
    
18.         For i = 1 To UBound(arr)
    
19.             xm = arr(i, 1) & "+" & arr(i, 4)
    
20.             If d.exists(xm) Then
    
21.                 arr(i, 7) = d(xm)
    
22.             End If
    
23.         Next
    
24.         .Range("a3:g" & r) = arr
    
25.     End With
    
26. End Sub
    

复制代码

chxw68

参与一下。

ＥＸＣＥＬ小子

1. Sub MatchWorkingHours_Array()
   
2.     Dim ws1 As Worksheet, ws2 As Worksheet
   
3.     Dim dict As Object
   
4.     Dim arr1, arr2, results()
   
5.     Dim lastRow1 As Long, lastRow2 As Long
   
6.     Dim i As Long, matchKey As String
   
7.     Dim t As Double
   
8.    
   
9.     t = Timer
   
10.     Application.ScreenUpdating = False
    
11.     Application.Calculation = xlCalculationManual
    
12.    
    
13.     ' 设置工作表对象
    
14.     Set ws1 = ThisWorkbook.Worksheets("人事H")
    
15.     Set ws2 = ThisWorkbook.Worksheets("SAPH")
    
16.    
    
17.     ' 读取表2数据到数组（A:D列）
    
18.     lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    
19.     arr2 = ws2.Range("A3:D" & lastRow2).Value
    
20.    
    
21.     ' 创建复合键字典
    
22.     Set dict = CreateObject("Scripting.Dictionary")
    
23.     For i = 1 To UBound(arr2)
    
24.         If Not IsEmpty(arr2(i, 1)) And Not IsEmpty(arr2(i, 3)) Then
    
25.             matchKey = CStr(arr2(i, 1)) & "|" & _
    
26.                       arr2(i, 3)
    
27.             dict(matchKey) = dict(matchKey) + arr2(i, 4)
    
28.         End If
    
29.     Next
    
30.    
    
31.     ' 读取表1数据到数组（A:A和D:D列）
    
32.     lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    
33.     arr1 = ws1.Range("A3:D" & lastRow1).Value
    
34.     ReDim results(1 To UBound(arr1), 1 To 1)
    
35.    
    
36.     ' 使用数组进行匹配
    
37.     For i = 1 To UBound(arr1)
    
38.         If Not IsEmpty(arr1(i, 1)) And Not IsEmpty(arr1(i, 4)) Then
    
39.             matchKey = CStr(arr1(i, 1)) & "|" & _
    
40.                       arr1(i, 4)
    
41.             
    
42.             If dict.Exists(matchKey) Then
    
43.                 results(i, 1) = dict(matchKey)
    
44.             Else
    
45.                 results(i, 1) = "未找到"
    
46.             End If
    
47.         Else
    
48.             results(i, 1) = "关键字段为空"
    
49.         End If
    
50.     Next
    
51.    
    
52.     ' 批量写回结果到G列
    
53.     ws1.Range("G3").Resize(UBound(results)).Value = results
    
54.    
    
55.    
    
56.    
    
57.     ' 清理资源
    
58.     Set dict = Nothing
    
59.     Application.Calculation = xlCalculationAutomatic
    
60.     Application.ScreenUpdating = True
    
61.    
    
62.     MsgBox "处理完成！共匹配 " & UBound(arr1) & " 条记录" & vbCrLf & _
    
63.            "总耗时：" & Format(Timer - t, "0.00") & " 秒", _
    
64.            vbInformation, "性能报告"
    
65. End Sub
    
66. 
    

复制代码

gwjkkkkk

写个公式

1. =SUMIFS(SAPH!D:D,SAPH!A:A,人事H!A3,SAPH!C:C,人事H!D3)

复制代码