本文于2023年10月5日首发于本人同名公众号：VBA编程实战，更多文章案例请搜索关注！

内容提要

数据结构转换

大家好，我是冷水泡茶，今天在某论坛上看到一则求助贴：[求助]数据转换,能用VBA快速转换吗？

他说用数据透视表实现不了，主要是标黄的部分有多个结果，数据透视表得分成两行。

这是一个数据结构转换加上记录合并的问题，我们可以通过数据+字典来解决，我们一起来看看吧。

基本思路

1、G列是名称，H1:N1是版本号，如果已经是准确地列出来了，可以用它来作为依据来取数。但我们写代码要考虑后续数据变化的问题，所以我们就当这不存在，重新从数据区域来提取，这里用字典的方法。

2、把A:D的数据装入数组arr()。

3、设置3个字典，dic1放名称，dic2放版本，dic3放“名称+版本"，循环数组arr，把所需数据存入字典。dic1、dic2只取它的keys，item随便；dic3的item为测试值。

4、把G1所在区域清空，先写入dic1、dic2的数据，然后再把G1所在区域读入数组arr

5、循环数组arr，把第一列，第一行的名称+版本号作为key到字典dic3中去取值，把测试字段的值存入数组。

6、把arr数组回写到工作表，完工。

VBA代码

1、在模块1里，Transform过程：

Sub Transform()    Dim ws As Worksheet    Dim lastRow As Integer    Dim lastCol As Integer    Dim dic1 As Object, dic2 As Object, dic3 As Object    Dim dKey As String    Dim arr()    Set dic1 = CreateObject("Scripting.Dictionary")    Set dic2 = CreateObject("Scripting.Dictionary")    Set dic3 = CreateObject("Scripting.Dictionary")    Set ws = ThisWorkbook.Sheets("Sheet1")    With ws        lastRow = .UsedRange.Rows.Count        lastCol = .UsedRange.Columns.Count        arr = .Range("A2:D" & lastRow).Value        For i = 1 To UBound(arr)            If arr(i, 1) <> "" Then                dic1(arr(i, 1)) = 1                dic2(arr(i, 2)) = 1                dKey = arr(i, 1) & "|" & arr(i, 2)                If Not dic3.exists(dKey) Then                    dic3(dKey) = arr(i, 3)                Else                    dic3(dKey) = dic3(dKey) & Chr(10) & arr(i, 3)                End If            End If        Next        .Range(Cells(1, 7), Cells(lastRow, lastCol)).Clear        .Range("G1") = "行标签"        .Range("G2").Resize(dic1.Count, 1) = Application.WorksheetFunction.Transpose(dic1.keys)        .Range("H1").Resize(1, dic2.Count) = dic2.keys        .Range("G1").CurrentRegion.Borders.LineStyle = xlContinuous        arr = .Range("G1").CurrentRegion        For i = 2 To UBound(arr)            For j = 2 To UBound(arr, 2)                dKey = arr(i, 1) & "|" & arr(1, j)                arr(i, j) = dic3(dKey)            Next        Next        .Range("G1").Resize(UBound(arr), UBound(arr, 2)) = arr    End WithEnd Sub

代码解析：

（1）line2~7，定义一些变量、对象、数组等。

（2）line8~10，创建字典对象。

（3）line15，把数据读入数组。

（4）line16~27，循环数组，把相关数据加入字典。其中，dic3的添加方式有所不同，如果有多个记录，需要换行排列。

（5）line28~32，把目标区域数据清空，填上新的行、列标题。

（6）line33，把目标区域（G1所在区域）装入数组arr。arr原来有数据，但已使用过了，我们再次利用它，不必重新定义另外一个数组，这样节约资源。

（7）line34~39，从第2行、第2列开始循环arr的所有元素，把它们对应的行列标题字段组合成一个字符串，作为字典的key，到dic3中去取值，赋值给该数组元素。

（8）line40，把arr数据再回写到工作表，完成数据转换。

2、在工作表Sheet1里，命令按钮CmdClear：

Private Sub CmdClear_Click()    Dim ws As Worksheet    Set ws = ThisWorkbook.Sheets("Sheet1")    With ws        lastRow = .UsedRange.Rows.Count        lastCol = .UsedRange.Columns.Count        .Range(Cells(1, 7), Cells(lastRow, lastCol)).Clear        .Range("G1") = "行标签"    End WithEnd Sub

代码解析：

（1）清除G列起右侧单元格的内容。

（2）在Transform主代码里，也包括了清除内容的代码。可以把它设为单独的过程调用。

后记

1、最后还是去浏览了一下这个帖子的回复，楼主后来又有新的想法，说重复的只取一次，由于不知道他的根本目的所在，懒得去追问了，就此作罢。

2、如果确定要剔除重复的测试结果，在我们的代码line24前后加上一个判断，应该就可以了。

If InStr(dic3(dKey), arr(i, 3)) = 0 Then     dic3(dKey) = dic3(dKey) & Chr(10) & arr(i, 3)End If

3、其实，我觉得在测试结果前应该加上日期。

4、看到有人用Power Query解决，也是一法，不过相对来说，局限性还是比较大的，比如，表头字段不能随便修改。

今天就这样。

~~~~~~End~~~~~~

喜欢就点个赞、点在看、留言评论、分享一下呗！感谢支持！