vba字典问题的二次求教。

wtzxuexivba

前期该问题在论坛大神的帮助下已解决部分需求，今需求增加，希望大神给与解答。

希望大神对以下两段代码分别进行改进，以满足需求，谢谢。

代码1：

Sub test()
    arr = Sheet1.[a1].CurrentRegion
    ReDim brr(1 To 9999, 1 To 6)
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        If arr(i, 4) <> 4 Then
            s = arr(i, 2) & arr(i, 3) & arr(i, 4)
            If Not d.exists(s) Then n = n + 1: d(s) = n
            m = d(s)
            brr(m, 1) = arr(i, 2): brr(m, 2) = arr(i, 3): brr(m, 3) = arr(i, 4)
            x = Application.Match(arr(i, 5), [{"A","B","C"}], 0) + 3
            brr(m, x) = brr(m, x) + arr(i, 6)
        End If
    Next
    Sheet1.[h1].CurrentRegion.Offset(1).Clear
    Sheet1.[h2].Resize(n, 6) = brr
    Sheet1.[h2].Resize(n, 6).Borders.LineStyle = 1
    Sheet1.[h2].Resize(n, 6).HorizontalAlignment = xlCenter
    Sheet1.[h1].Resize(1, 6).Columns.AutoFit
    Beep
End Sub

ynzsvt

结果在另一个工作表中。

沈默00

数透来一个。。。

wtzxuexivba

谢谢各位的帮助，你们辛苦啦！

Qs18

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. With Sheet1
   
5.     r = .Cells(Rows.Count, 2).End(3).Row
   
6.     arr = .Range("b2:f" & r).Value
   
7.     ReDim brr(1 To 10000, 1 To 100)
   
8.     For i = 1 To UBound(arr)
   
9.         If arr(i, 3) <> 4 Then
   
10.             s = arr(i, 1) & arr(i, 2) & arr(i, 3): s2 = arr(i, 4)
    
11.             If Not dic.exists(s) Then
    
12.                 m = m + 1
    
13.                 dic(s) = m
    
14.                 brr(m, 1) = arr(i, 1): brr(m, 2) = arr(i, 2): brr(m, 3) = arr(i, 3)
    
15.                 If s2 = "A" Then brr(m, 4) = 1: brr(m, 5) = arr(i, 5)
    
16.                 If s2 = "B" Then brr(m, 6) = 1: brr(m, 7) = arr(i, 5)
    
17.                 If s2 = "C" Then brr(m, 8) = 1: brr(m, 9) = arr(i, 5)
    
18.             Else
    
19.                 rw = dic(s)
    
20.                 If s2 = "A" Then brr(rw, 4) = brr(rw, 4) + 1: brr(rw, 5) = brr(rw, 5) + arr(i, 5)
    
21.                 If s2 = "B" Then brr(rw, 6) = brr(rw, 6) + 1: brr(rw, 7) = brr(rw, 7) + arr(i, 5)
    
22.                 If s2 = "C" Then brr(rw, 8) = brr(rw, 8) + 1: brr(rw, 9) = brr(rw, 9) + arr(i, 5)
    
23.             End If
    
24.         End If
    
25.     Next
    
26.     .[h2].Resize(10000, 9).Clear
    
27.     .[h2].Resize(m, 9) = brr
    
28.     .[h2].Resize(m, 9).Borders.LineStyle = 1
    
29.     .[h2].Resize(m, 9).HorizontalAlignment = xlCenter
    
30.     .[h1].Resize(1, 9).Columns.AutoFit
    
31.     Beep
    
32. End With
    
33. Set dic = Nothing: Set d2 = Nothing
    
34. End Sub
    

复制代码

Qs18

试试..........

Qs18

试试............

wtzxuexivba

Qs18 发表于 2024-9-22 11:42
试试............

感谢老师的精彩回复。因本人是初入论坛，对一些基础知识掌握的不太不是太好，还望老师对您的以下代码进行解读（我自己读的有点晕）：
If arr(i, 3) <> 4 Then
            s = arr(i, 1) & arr(i, 2) & arr(i, 3): s2 = arr(i, 4)
            If Not dic.exists(s) Then
                m = m + 1
                dic(s) = m
                brr(m, 1) = arr(i, 1): brr(m, 2) = arr(i, 2): brr(m, 3) = arr(i, 3)
                If s2 = "A" Then brr(m, 4) = 1: brr(m, 5) = arr(i, 5)
                If s2 = "B" Then brr(m, 6) = 1: brr(m, 7) = arr(i, 5)
                If s2 = "C" Then brr(m, 8) = 1: brr(m, 9) = arr(i, 5)
            Else
                rw = dic(s)
                If s2 = "A" Then brr(rw, 4) = brr(rw, 4) + 1: brr(rw, 5) = brr(rw, 5) + arr(i, 5)
                If s2 = "B" Then brr(rw, 6) = brr(rw, 6) + 1: brr(rw, 7) = brr(rw, 7) + arr(i, 5)
                If s2 = "C" Then brr(rw, 8) = brr(rw, 8) + 1: brr(rw, 9) = brr(rw, 9) + arr(i, 5)
            End If
        End If