vba 字典统计求教

wtzxuexivba

vba字典问题求教，希望大神给与解答。

quqiyuan

参与一下，供参考。。。

longwin

请测试。。。。。

我是龙五

1. Sub test() 'VX:longwuVBA
   
2.     Dim lastRow, Arr, Brr(), Dic, Dic1, Dic2, key
   
3.     Set Dic = CreateObject("scripting.dictionary")
   
4.     Set Dic1 = CreateObject("scripting.dictionary")
   
5.     Set Dic2 = CreateObject("scripting.dictionary")
   
6.     lastRow = Sheet1.Cells(Rows.Count, 1).End(3).Row
   
7.     Arr = Sheet1.Range("A2:F" & lastRow)
   
8.     For i = 1 To UBound(Arr)
   
9.         If Not Dic1.exists(Arr(i, 5)) Then
   
10.             l = l + 1
    
11.             Dic1(Arr(i, 5)) = l
    
12.         End If
    
13.         If Arr(i, 4) <> 4 Then
    
14.             key = Arr(i, 2) & "|" & Arr(i, 3) & "|" & Arr(i, 4) & "|" & Arr(i, 5)
    
15.             If Not Dic.exists(key) Then
    
16.                 k = k + 1
    
17.                 Dic(key) = k
    
18.             End If
    
19.             Dic2(key) = Dic2(key) + Arr(i, 6)
    
20.         End If
    
21.     Next
    
22.     dickey = Dic.keys
    
23.     dickey1 = Dic1.keys
    
24.     ReDim Brr(1 To 10000, 1 To 10)
    
25.     For i = 1 To Dic.Count
    
26.         temp = Split(dickey(i - 1), "|")
    
27.         Brr(Dic(dickey(i - 1)), Dic1(temp(3)) + 3) = Brr(Dic(dickey(i - 1)), Dic1(temp(3)) + 3) + Dic2(dickey(i - 1))
    
28.         Brr(Dic(dickey(i - 1)), 1) = temp(0)
    
29.         Brr(Dic(dickey(i - 1)), 2) = temp(1)
    
30.         Brr(Dic(dickey(i - 1)), 3) = temp(2)
    
31.     Next
    
32.     Range("H2").Resize(Dic.Count, Dic1.Count + 3) = Brr
    
33. End Sub

复制代码

taller

1. Sub ADOSqlQuery()
   
2.     Dim conn As Object, rst As Object, strSQL$, i&, PathStr$, sht As Worksheet
   
3.     Set conn = CreateObject("ADODB.Connection")
   
4.     Set rst = CreateObject("ADODB.Recordset")
   
5.     PathStr = ThisWorkbook.FullName                                     '路径
   
6.     Select Case Application.Version * 1
   
7.         Case Is <= 11
   
8.             conn.Open "Provider=Microsoft.Jet.Oledb.4.0;Data Source=" & PathStr & ";Extended Properties='Excel 8.0;HDR=Yes;IMEX=0'"
   
9.         Case Is >= 12
   
10.             conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties='Excel 12.0;HDR=Yes;IMEX=0'"
    
11.     End Select
    
12.     ActiveSheet.Range("H:M").Clear
    
13.     strSQL = "TRANSFORM sum(个数) select 生产厂, 生产班组, 产品等级 from [" & _
    
14.         ActiveSheet.Name & "$] where 工序组<>4 group by 生产厂, 生产班组, 产品等级 PIVOT 产品等级 "
    
15.     rst.Open strSQL, conn, 1, 1
    
16.     Set sht = Worksheets.Add(ActiveSheet)
    
17.     With sht
    
18.         For i = 0 To rst.Fields.Count - 1
    
19.             .Cells(1, i + 1) = IIf(i > 2, rst.Fields(2).Name, "") & rst.Fields(i).Name
    
20.         Next i
    
21.         .Range("a2").CopyFromRecordset rst
    
22.         .Columns(3).Delete
    
23.     End With
    
24.     rst.Close:    conn.Close:    Set conn = Nothing:    Set rst = Nothing
    
25. End Sub
    

复制代码

shenjianrong163

quqiyuan 发表于 2024-6-14 23:12
参与一下，供参考。。。

这代码简洁！

yynrzwh

1. Sub test()
   
2. 
   
3. Set d = CreateObject("scripting.dictionary")
   
4. 
   
5. With Sheet1
   
6.     ar = .Range("a1").CurrentRegion
   
7.     For i = 2 To UBound(ar)
   
8.         If ar(i, 4) <> 4 Then
   
9.             s = ar(i, 2) & "|" & ar(i, 3) & "|" & ar(i, 4)
   
10.             If Not d.exists(s) Then
    
11.                 Set d(s) = CreateObject("scripting.dictionary")
    
12.             End If
    
13.             ss = ar(1, 5) & ar(i, 5)
    
14.             d(s)(ss) = d(s)(ss) + ar(i, 6)
    
15.         End If
    
16.     Next
    
17.    
    
18.     ReDim br(1 To d.Count, 1 To 6)
    
19.     For Each k In d.keys
    
20.         r = r + 1
    
21.         st = Split(k, "|")
    
22.         For x = 0 To UBound(st)
    
23.             br(r, x + 1) = st(x)
    
24.         Next
    
25.         For j = 4 To UBound(br, 2)
    
26.             br(r, j) = d(k)(.Cells(1, j + 7).Value)
    
27.         Next
    
28.     Next
    
29.    
    
30.     .Range("h2").CurrentRegion.Offset(1).Clear
    
31.     With .Range("h2").Resize(r, UBound(br, 2))
    
32.         .Value = br
    
33.         .HorizontalAlignment = xlCenter
    
34.         .Borders.LineStyle = 1
    
35.     End With
    
36. End With
    
37. 
    
38. Set d = Nothing
    
39. End Sub
    

复制代码

mmwwdd

Sub test()
Dim aa, bb, cc
Dim sh As Worksheet
Set sh = Sheets("Sheet1")
Set d = CreateObject("scripting.dictionary")
With Sheets("Sheet1")
r = .Cells(.Rows.Count, 1).End(3).Row
For i = 2 To r
  s = .Cells(i, 2) & "-" & .Cells(i, 3) & "-" & .Cells(i, 4)
  If Not d.exists(s) Then
     Set d(s) = CreateObject("scripting.dictionary")
  End If
     d(s)(.Cells(i, 5).Value) = d(s)(.Cells(i, 5).Value) + .Cells(i, 6).Value
Next
k = 2
End With
  For Each aa In d.keys
       dd = Split(aa, "-")
       sh.Cells(k, 8).Resize(1, 3) = Application.Transpose(Application.Transpose(dd))
       For Each cc In d(aa).keys
      Select Case cc
             Case "A"
               sh.Cells(k, 11) = d(aa)(cc)
             Case "B"
              sh.Cells(k, 12) = d(aa)(cc)
             Case "C"
               sh.Cells(k, 13) = d(aa)(cc)
        End Select
       Next
       Erase dd
       k = k + 1
  Next
     
  
End Sub

wtzxuexivba

quqiyuan 发表于 2024-6-14 23:12
参与一下，供参考。。。

感谢大神帮助。

wtzxuexivba

感谢各位大神的帮助。