用字典法做透视表求助

Dragonfly7995

想用字典法做透视表，显示各店的对应商品价格，总是不得其法，请大神指点

yech20

蓝色幻想数组字典下棋法

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, brr, i, j, dic, t
  Set dic = CreateObject("scripting.dictionary")
  arr = Sheets("价目表").[a1].CurrentRegion
  For i = 2 To UBound(arr, 1)
    For j = 2 To UBound(arr, 2)
      dic(arr(i, 1) & arr(1, j)) = Array(i, j)
  Next j, i
  brr = Sheets("筛选数据2").[a1].CurrentRegion
  For i = 2 To UBound(brr, 1)
    t = brr(i, 5) & brr(i, 3)
    If dic.exists(t) Then
      arr(dic(t)(0), dic(t)(1)) = brr(i, 8)
    Else
      Debug.Print i, brr(i, 5), brr(i, 3)
    End If
  Next
  Sheets("价目表").[a1].CurrentRegion = arr
End Sub

xiangbaoan

Sub test() '透视表式统计
Dim m$, s$
Dim d1 As Object, d2 As Object, br, ar()
Dim i&, y%, x%, h%, w%
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
br = Sheet4.[a1].CurrentRegion
For i = 1 To UBound(br)
    s = br(i, 5)
    If Not d1.exists(s) Then
        x = x + 1
        d1(s) = x
    End If
Next
h = d1.Count
w = 1
ReDim ar(1 To h, 1 To w)
For i = 1 To h
    ar(i, 1) = d1.keys()(i - 1)
Next
For i = 2 To UBound(br)
    m = br(i, 3)
    If Not d2.exists(m) Then
        w = w + 1
        ReDim Preserve ar(1 To h, 1 To w)
        ar(1, w) = br(i, 3)
        d2(m) = w
    End If
    x = d2(m)
    y = d1(br(i, 5))
    ar(y, x) = br(i, 8)
Next
Sheet3.[a1].Resize(h, w) = ar
Set d1 = Nothing
Set d2 = Nothing
End Sub

Dragonfly7995

xiangbaoan 发表于 2019-5-30 12:57
Sub test() '透视表式统计
Dim m$, s$
Dim d1 As Object, d2 As Object, br, ar()

非常有限，谢谢

Dragonfly7995

一把小刀闯天下 发表于 2019-5-30 12:19
Option Explicit

Sub test()

If dic.exists(t) Then
      arr(dic(t)(0), dic(t)(1)) = brr(i, 8)
    Else
      Debug.Print i, brr(i, 5), brr(i, 3)
    End If
可以解释一下这两句代码的含义吗

thymethy

1. <div>请参考</div><div>Sub ss1()
   
2. </div>Dim d As Object, arr, i%, j%, s$, brr()
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheets("??????2").[a1].CurrentRegion
   
5. For i = 2 To UBound(arr)
   
6.     s = arr(i, 5) & arr(i, 3)
   
7.     d(s) = arr(i, 8)
   
8. Next
   
9. With Sheets(2)
   
10. For i = 2 To .[a65536].End(3).Row
    
11.     For j = 2 To .Cells(1, Columns.Count).End(xlToLeft).Column
    
12.         s = .Cells(i, 1) & .Cells(1, j)
    
13.         If d.exists(s) Then .Cells(i, j) = d(s)
    
14.     Next
    
15. Next
    
16. End With
    
17. Set d = Nothing
    
18. End Sub
    
19. 
    

复制代码

everbest2015

分店代码，商品名称，都相同的取哪一次的单价呢

Dragonfly7995

everbest2015 发表于 2019-6-21 13:46
分店代码，商品名称，都相同的取哪一次的单价呢

每个店都有一个自己的单价，以销售额除以销售数获得