数据位置的的问题

gawenh

请教一下，用vba要怎么实现这种效果

iwangyi

Sub 用字典方法统计()
Set D = CreateObject("SCRIPTING.DICTIONARY")
Set d1 = CreateObject("SCRIPTING.DICTIONARY")
ARR = Range("A1").CurrentRegion
ReDim BRR(1 To UBound(ARR), 1 To UBound(ARR)) '
n = 1
For I = 2 To UBound(ARR)
S = ARR(I, 1): f = ARR(I, 3)
If Not D.EXISTS(S) Then
M = M + 1
D(S) = M
End If
If Not d1.EXISTS(f) Then
n = n + 1
d1(f) = n
Cells(1, 5 + n) = f
BRR(M, 1) = ARR(I, 1)
BRR(M, n) = ARR(I, 2)
Else
BRR(D(S), d1(f)) = BRR(D(S), d1(f)) + ARR(I, 2)
End If
Next
[f2].Resize(M, n) = BRR
[f1] = "word"
End Sub

iwangyi

附件请参考

gawenh

iwangyi 发表于 2018-8-30 19:15
附件请参考

好的，太感谢了，就是要这样的

iwangyi

不客气，满意可送花

gawenh

iwangyi 发表于 2018-8-30 22:31
不客气，满意可送花

要怎么送花了，不懂的怎么操作了

iwangyi

右下角看到那个手么，点击，按提示操作

gawenh

iwangyi 发表于 2018-8-30 22:47
右下角看到那个手么，点击，按提示操作

你好，我还有一个问题，能不能把日期跟水果的对调一下位置

iwangyi

Sub 用字典方法统计()
Set D = CreateObject("SCRIPTING.DICTIONARY")
Set d1 = CreateObject("SCRIPTING.DICTIONARY")
ARR = Range("j1").CurrentRegion
ReDim BRR(1 To UBound(ARR), 1 To UBound(ARR)) '
n = 1
For I = 2 To UBound(ARR)
S = ARR(I, 3): f = ARR(I, 1)
If Not D.EXISTS(S) Then
M = M + 1
D(S) = M
End If
If Not d1.EXISTS(f) Then
n = n + 1
d1(f) = n
Cells(1, n) = f
BRR(M, 1) = ARR(I, 3)
BRR(M, n) = ARR(I, 2)
Else
BRR(D(S), d1(f)) = BRR(D(S), d1(f)) + ARR(I, 2)
End If
Next
[A2].Resize(M, n) = BRR
[A1] = "word"
Range("A1").CurrentRegion.Borders.ColorIndex = 7
End Sub

iwangyi

按楼主要求己改为日期竖排，水果名称横排的要求