【SOS】头都搞晕了,求思路!~~~

Stone_00x

liulang0808 发表于 2019-12-11 07:34
基本思路就是根据c列是100，B列是B开头的，以A列为关键字，读入字典ddd是以A列为关键字，将B列加入字典。
...

如果我要将比例加上去,该怎么改呢?....

liulang0808

1. Sub 按钮1_Click()
   
2.     Dim brr()
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set dd = CreateObject("scripting.dictionary")
   
5.     Set dc = CreateObject("scripting.dictionary")
   
6.     arr = [a1].CurrentRegion
   
7.     x = WorksheetFunction.CountIf(Columns(3), 100)
   
8.     ReDim brr(1 To UBound(arr) * x, 1 To 1)
   
9.     Application.ScreenUpdating = False
   
10.     For j = 2 To UBound(arr)
    
11.         If arr(j, 3) = 100 And Left(arr(j, 2), 1) = "B" Then d(arr(j, 1)) = d(arr(j, 1)) & "," & arr(j, 2)
    
12.         dd(arr(j, 1)) = dd(arr(j, 1)) & "," & arr(j, 2) & "@" & arr(j, 3)
    
13.     Next j
    
14.     r = 0
    
15.     For j = 0 To d.Count - 1
    
16.         crr = Split(d.items()(j), ",")
    
17.         For i = 1 To UBound(crr)
    
18.             If dd.exists(crr(i)) Then
    
19.                 arr = Split(dd(crr(i)), ",")
    
20.                 For l = 1 To UBound(arr)
    
21.                     str1 = d.keys()(j) & "&" & arr(l)
    
22.                     If Not dc.exists(str1) Then
    
23.                         r = r + 1
    
24.                         brr(r, 1) = d.keys()(j) & "&" & arr(l)
    
25.                         dc(str1) = ""
    
26.                     End If
    
27.                 Next l
    
28.             End If
    
29.         Next i
    
30.     Next j
    
31.     [k1].Resize(r) = brr
    
32.     Columns(11).TextToColumns Destination:=Range("K1"), DataType:=xlDelimited, _
    
33.         TextQualifier:=xlDoubleQuote, Other:=True, OtherChar:="@"
    
34.     Application.ScreenUpdating = True
    
35. End Sub
    

复制代码