如今流行卷公式，可我偏偏卷代码，这算不算是没苦硬吃呢？

欢迎转发和点一下“在看”，文末留言互动!

置顶公众号或设为星标及时接收更新不迷路

朋友们好，这里是EXCEL应用之家，坚持分享EXCEL操作技巧。

今天和大家分享一道VBA表格转换的题目。如下图。

同类型的题目我们分享过多次了，一小段VBA代码就可以解决问题。不过今天会有一段非常新颖的代码技巧分享在文末。

VBA字典方法

完整代码如下：

Sub 转换()    Dim i%, j%, arr, brr, crr, mydic, d    Set mydic = CreateObject("scripting.dictionary")    arr = Range("A4:B6")    ReDim crr(1 To 10, 1 To 1)    For i = 1 To UBound(arr)        brr = Split(arr(i, 2), "、")        For j = 0 To UBound(brr)            mydic(j & arr(i, 1)) = brr(j)        Next    Next    For j = 0 To mydic.Count - 1        crr(j + 1, 1) = Mid(mydic.keys()(j), 2)    Next    [h3].Resize(1, 2) = Array("水果分类", "水果")    [H4].Resize(mydic.Count, 1) = crr    [I4].Resize(mydic.Count, 1) = Application.Transpose(mydic.items)End Sub

简单讲一讲。

For j = 0 To UBound(brr)  mydic(j & arr(i, 1)) = brr(j)Next

将每行中的水果拆分出来后，装入字典。这里使用序号和类别共同构成字典的键。

For j = 0 To mydic.Count - 1  crr(j + 1, 1) = Mid(mydic.keys()(j), 2)Next

将键中的分类信息提取出来赋值到数组crr中。

[h3].Resize(1, 2) = Array("水果分类", "水果")[H4].Resize(mydic.Count, 1) = crr[I4].Resize(mydic.Count, 1) = Application.Transpose(mydic.items)

最后结果输出。

简洁的代码

完整代码如下：

Sub 转换1()    Dim i%, j%, arr, brr, mydic    Set mydic = CreateObject("scripting.dictionary")    arr = Range("A4:B6")    For i = 1 To UBound(arr)        brr = Split(arr(i, 2), "、")        For j = 0 To UBound(brr)            mydic(brr(j)) = arr(i, 1)        Next    Next    [h3].Resize(1, 2) = Array("水果分类", "水果")    [H4].Resize(mydic.Count, 2) = Application.Transpose( _    Array(mydic.items, mydic.keys))End Sub

一句话解释：

直接把水果作为键，类别作为键值，装入字典。

更加简洁的代码

完整代码如下：

Sub test()Dim ss, sss, n, arr(1 To 100, 1 To 2)For Each ss In [b3:b6]    For Each sss In Split(ss, "、")        n = n + 1        arr(n, 1) = ss.Offset(, -1)        arr(n, 2) = sssNext sss, ss[h3].Resize(n, 2) = arrEnd Sub

巧妙吧？朋友们理解这段代码了吗？

我就知道你“在看”