能否用VBA解决一个筛选问题？

morningmiss · 发表于 2017-9-20 20:04

如图所示，将水果为列城市为行，处理为城市为列，水果为行。这里只是举一个例子，实际要处理的量很大。求各位大大们，教下小妹，学习一下，谢谢各位大神。

smhf_6 · 发表于 2017-9-20 20:51

Sub sadhjk()
Dim dc As Object
Dim arr, i, j, ir
Dim brr(), p, q, b
ir = Range("a1").End(xlDown).Row
arr = Range("a2:f" & ir)

Set dc = CreateObject("scripting.dictionary")
For i = 1 To 4
For j = 2 To 6
If dc.exists(arr(i, j)) = False Then
dc(arr(i, j)) = arr(i, 1)
Else
dc(arr(i, j)) = dc(arr(i, j)) & "|" & arr(i, 1)
End If
Next
Next

ReDim brr(1 To dc.Count, 1 To ir)
p = dc.keys
q = dc.items
For i = 0 To UBound(p)
brr(i + 1, 1) = p(i)
b = Split(q(i), "|")
For j = 0 To UBound(b)
brr(i + 1, j + 2) = b(j)
Next
Next

Sheet2.Select
Cells.ClearContents
Range("a2").Resize(dc.Count, ir) = brr

Set dc = Nothing
End Sub

CC例例 · 发表于 2017-9-20 20:52

数据有点少，一个问题，实际操作中A列种类是否有重复值？

jiangxiaoyun · 发表于 2017-9-20 21:26

Sub vv()
Dim arr, brr(1 To 10000, 1 To 15)
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
arr = [a1].CurrentRegion
For i = 2 To UBound(arr)
For j = 2 To UBound(arr, 2)
If Not d.exists(arr(i, j)) Then
r = r + 1
brr(r, 1) = arr(i, j)
d(arr(i, j)) = r
End If
If Not d1.exists(arr(i, j)) Then
d1(arr(i, j)) = 2
brr(r, 2) = arr(i, 1)
Else
d1(arr(i, j)) = d1(arr(i, j)) + 1
brr(d(arr(i, j)), d1(arr(i, j))) = arr(i, 1)
End If
Next
Next
[i2:w100000] = ""
[i2].Resize(r, 15) = brr
End Sub

复制代码

新建文档.zip (20.55 KB, 下载次数: 6)

morningmiss · 发表于 2017-9-20 22:33

CC例例发表于 2017-9-20 20:52
数据有点少，一个问题，实际操作中A列种类是否有重复值？

没有重复值

morningmiss · 发表于 2017-9-20 22:34

jiangxiaoyun 发表于 2017-9-20 21:26

向您学习了，谢谢大佬~

morningmiss · 发表于 2017-9-20 22:58

smhf_6 发表于 2017-9-20 20:51
Sub sadhjk()
Dim dc As Object
Dim arr, i, j, ir

谢谢大人~我学习一下看看能不能扩展更多

CC例例 · 发表于 2017-9-21 08:13

本帖最后由 CC例例于 2017-9-21 08:15 编辑

Sub Test()
Dim d, arA, k, i&, x%, y%
Set d = CreateObject("Scripting.Dictionary")
[i1].CurrentRegion.Offset(1).ClearContents
arA = [a1].CurrentRegion
y = UBound(arA) - 1
For i = 2 To UBound(arA)
For x = 2 To UBound(arA, 2)
If Not d.Exists(arA(i, x)) Then
ReDim k(y)
k(0) = arA(i, x)
k(1) = arA(i, 1)
k(y) = 1
Else
k = d(arA(i, x))
k(y) = k(y) + 1
k(k(y)) = arA(i, 1)
End If

复制代码

CC例例 · 发表于 2017-9-21 08:17

编辑一下，就成这样啦，重新贴上

Sub Test()
Dim d, arA, k, i&, x%, y%
Set d = CreateObject("Scripting.Dictionary")
[i1].CurrentRegion.Offset(1).ClearContents
arA = [a1].CurrentRegion
y = UBound(arA) - 1
For i = 2 To UBound(arA)
For x = 2 To UBound(arA, 2)
If Not d.Exists(arA(i, x)) Then
ReDim k(y)
k(0) = arA(i, x)
k(1) = arA(i, 1)
k(y) = 1
Else
k = d(arA(i, x))
k(y) = k(y) + 1
k(k(y)) = arA(i, 1)
End If
d(arA(i, x)) = k
Next
Next
[i2].Resize(d.Count, y) = Application.Rept(d.Items, 1)
Set d = Nothing
End Sub

复制代码

CC例例 · 发表于 2017-9-21 08:30

附件供参考

		自动登录	找回密码
密码			免费注册

[求助] 能否用VBA解决一个筛选问题？

最新热点 /1