字典与数组

zymwhy

各位老师，初学字典与数组，用了两个字典四个数组才搞定，有没有再简洁的代码实现呢？多谢指点

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("需要的人员")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a1:a" & r)
   
9.     For i = 2 To UBound(arr)
   
10.       d(arr(i, 1)) = 0
    
11.     Next
    
12.   End With
    
13.   With Worksheets("数据")
    
14.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
15.     arr = .Range("a2:b" & r)
    
16.     For i = 1 To UBound(arr)
    
17.       If d.exists(arr(i, 1)) Then
    
18.         d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
    
19.       End If
    
20.     Next
    
21.   End With
    
22.   With Worksheets("需要的数据")
    
23.     .Range("a2").Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
    
24.   End With
    
25. End Sub
    

复制代码

chxw68

仅供参考。

chis3

Sub test()
    Dim dic As Object: Set dic = CreateObject("scripting.dictionary")
    Dim arr
    Dim brr()
    Dim i As Byte
    Dim j As Byte
    arr = Sheets(1).[a1].CurrentRegion
    For i = 2 To UBound(arr)
        dic(arr(i, 1)) = dic(arr(i, 1)) + arr(i, 2)
    Next i
    arr = Sheets(2).[a1].CurrentRegion
    For i = 2 To UBound(arr)
        If dic.exists(arr(i, 1)) Then
            j = j + 1
            ReDim Preserve brr(1 To 2, 1 To j)
            brr(1, j) = arr(i, 1)
            brr(2, j) = dic(arr(i, 1))
        End If
    Next i
    [g2].Resize(j, 2) = Application.Transpose(brr)
    Set dic = Nothing
End Sub

cjc209

Sub test()
Dim d
Dim arr, crr
Set d = CreateObject("scripting.dictionary") '数据除重累计字典
crr = Sheets("需要的人员").UsedRange
For i = 2 To UBound(crr)
    d(crr(i, 1)) = 0
Next
arr = Sheets("数据").UsedRange
For i = 2 To UBound(arr)
    If d.exists(arr(i, 1)) Then
        d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
     
    End If
Next
Sheets("需要的数据").[a1].CurrentRegion.Offset(1).ClearContents
Sheets("需要的数据").Range("a2").Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
Sheets("需要的数据").Range("b2").Resize(d.Count, 1) = WorksheetFunction.Transpose(d.items)
End Sub

cjc209

就这样就足够了

魂断蓝桥

Sub 查询()
Dim cnn As Object
Dim Sql As String
Set cnn = CreateObject("ADODB.CONNECTION")
Application.ScreenUpdating = False
cnn.Open "Provider=Microsoft.ACE.OleDb.12.0;Extended Properties='Excel 12.0;HDR=YES'; Data Source=" & ThisWorkbook.FullName
Sql = "select 姓名,SUM(工资) from [数据$a1:b] group by 姓名 "
Sql = "select * from (" & Sql & ") where 姓名 IN (SELECT 姓名 from [需要的人员$A1:A] WHERE 姓名 is not null)"
Sheet3.Activate
Cells.Clear
[a2].CopyFromRecordset cnn.Execute(Sql)
cnn.Close: Set cnn = Nothing
Application.ScreenUpdating = True
End Sub

cjc209

用不住哦那样复杂
Sub test()
    Dim d
    Dim arr, crr
    Set d = CreateObject("scripting.dictionary") '数据除重累计字典
    crr = Sheets("需要的人员").UsedRange
    For i = 2 To UBound(crr)
        d(crr(i, 1)) = 0
    Next
    arr = Sheets("数据").UsedRange
    For i = 2 To UBound(arr)
        If d.exists(arr(i, 1)) Then
            d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
        End If
    Next
    Sheets("需要的数据").[a1].CurrentRegion.Offset(1).ClearContents
    Sheets("需要的数据").Range("a2").Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
    Sheets("需要的数据").Range("b2").Resize(d.Count, 1) = WorksheetFunction.Transpose(d.items)
End Sub

qingc0221

多表查询sql是最简洁的

liujialin0o0

Sub t()
arr = Sheets(1).[A1].CurrentRegion
brr = Sheets(2).Range("A1:B" & Sheets(2).Cells(Rows.Count, 1).End(3).Row)
Set d = CreateObject("scripting.dictionary")

For i = 1 To UBound(arr, 1)
    d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
Next

For j = 1 To UBound(brr, 1)
    For i = 1 To d.Count
        If brr(j, 1) = d.keys()(i - 1) Then
            brr(j, 2) = d.items()(i - 1)
        End If
    Next
Next
[A1].Resize(UBound(brr, 1), 2) = brr

End Sub