VBA如何实现这个透视

czr0373

我能用的方法，一是透视表
二是vlookup+sumproduct
用VBA试一下，，怎么搞？？

ione_fox

1. Sub test() 'http://club.excelhome.net/thread-1433441-1-1.html
   
2. Dim Ar, I&, Br, K&, Dic, J&
   
3. Set Dic = CreateObject("Scripting.Dictionary")
   
4. Ar = Sheets("sheet1").Range("a1:e" & Cells(Rows.Count, 5).End(3).Row)
   
5. ReDim Br(1 To UBound(Ar), 1 To 3)
   
6.     For I = 2 To UBound(Ar)
   
7.         If Ar(I, 5) <> "" Then
   
8.             If Dic(Ar(I, 5)) = "" Then
   
9.                 K = K + 1
   
10.                 Dic(Ar(I, 5)) = K
    
11.                 Br(K, 1) = Ar(I, 5)
    
12.             End If
    
13.             Br(Dic(Ar(I, 5)), 2) = Br(Dic(Ar(I, 5)), 2) + Ar(I, 2)
    
14.             Br(Dic(Ar(I, 5)), 3) = Br(Dic(Ar(I, 5)), 3) + Ar(I, 4)
    
15.         End If
    
16.     Next I
    
17.     Sheets("sheet1").Range("g2:i1000").ClearContents
    
18.     Sheets("sheet1").Range("g2").Resize(K, 3) = Br
    
19. End Sub
    

复制代码

ione_fox

附件请测试，OK请好评 给小花

zhenghui13

aa和cc的值怎么处理呢？

lsc900707

字典的基本运用问题：

1. Sub gj23w98()
   
2.     Dim brr(1 To 1000, 1 To 3)
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = ActiveSheet.UsedRange
   
5.     For x = 2 To UBound(arr)
   
6.         s = arr(x, 5)
   
7.         If Len(s) Then
   
8.             If d(s) = "" Then
   
9.                 m = m + 1
   
10.                 d(s) = m
    
11.                 brr(m, 1) = arr(x, 5)
    
12.                 brr(m, 2) = arr(x, 2)
    
13.                 brr(m, 3) = arr(x, 4)
    
14.             Else
    
15.                 brr(d(s), 2) = brr(d(s), 2) + arr(x, 2)
    
16.                 brr(d(s), 3) = brr(d(s), 3) + arr(x, 4)
    
17.             End If
    
18.         End If
    
19.     Next
    
20.     Set d = Nothing
    
21.     [g1].CurrentRegion.Offset(1).ClearContents
    
22.     [g2].Resize(m, 3) = brr
    
23. End Sub

复制代码

lsc900707

代码需要审核，附件先回传供测试参考：

czr0373

ione_fox 发表于 2018-8-31 16:36
附件请测试，OK请好评 给小花

请教，要是结果转置为横排呢？

czr0373

lsc900707 发表于 2018-8-31 21:52
代码需要审核，附件先回传供测试参考：

版主，请教，要是结果横排呢？

ione_fox

1. Option Explicit
   
2. 
   
3. Sub test() 'http://club.excelhome.net/thread-1433441-1-1.html
   
4. Dim Ar, I&, Br, K&, Dic, J&
   
5. Set Dic = CreateObject("Scripting.Dictionary")
   
6. Ar = Sheets("sheet1").Range("a1:e" & Cells(Rows.Count, 5).End(3).Row)
   
7. ReDim Br(1 To UBound(Ar), 1 To 3)
   
8.     For I = 2 To UBound(Ar)
   
9.         If Ar(I, 5) <> "" Then
   
10.             If Dic(Ar(I, 5)) = "" Then
    
11.                 K = K + 1
    
12.                 Dic(Ar(I, 5)) = K
    
13.                 Br(K, 1) = Ar(I, 5)
    
14.             End If
    
15.             Br(Dic(Ar(I, 5)), 2) = Br(Dic(Ar(I, 5)), 2) + Ar(I, 2)
    
16.             Br(Dic(Ar(I, 5)), 3) = Br(Dic(Ar(I, 5)), 3) + Ar(I, 4)
    
17.         End If
    
18.     Next I
    
19.     'Stop
    
20.     Sheets("sheet1").Range("g1").CurrentRegion.ClearContents
    
21.     Sheets("sheet1").Range("h1") = Ar(1, 2)
    
22.     Sheets("sheet1").Range("i1") = Ar(1, 4)
    
23.     Sheets("sheet1").Range("g2").Resize(K, 3) = Br
    
24. End Sub
    
25.     Sub test1() ' 第二步在原有位置上转转置
    
26.         Dim Ar
    
27.         Ar = Sheets("sheet1").Range("g1").CurrentRegion
    
28.         Sheets("sheet1").Range("g1").CurrentRegion.ClearContents
    
29.         Sheets("sheet1").Range("g1").Resize(UBound(Ar, 2), UBound(Ar)) = Application.WorksheetFunction.Transpose(Ar)
    
30.     End Sub

复制代码

ione_fox

sub test1为转置横排病修改部分原先代码。好用请给小花