|
欢迎转发和点一下“在看”，文末留言互动! 置顶公众号或设为星标及时接收更新不迷路 小伙伴们好，今天我们来做一道VBA的题目。通过一段代码提取并改变一个数据的结构。 原题目是这样子的： 需要将标记为“已完成”的数据提取出来并转变成一个二维的表。今天这里会有三段代码分享给大家。 完整代码如下： Sub 转换结构() Dim myarr As Variant, mydic As Object, i As Integer, d, k, mybrr myarr = Range("A1").CurrentRegion Set mydic = CreateObject("scripting.dictionary") For i = 2 To UBound(myarr) If myarr(i, 3) = "已完成" Then If mydic.exists(myarr(i, 1)) Then mydic(myarr(i, 1)) = mydic(myarr(i, 1)) & "@" & myarr(i, 2) Else mydic(myarr(i, 1)) = myarr(i, 2) End If End If Next i ReDim mybrr(1 To mydic.Count, 1 To 100) For Each d In mydic.keys k = k + 1 mybrr(k, 1) = Split(d, "@")(0) For i = 0 To UBound(Split(mydic(d), "@")) mybrr(k, i + 2) = Split(mydic(d), "@")(i) Next i Next [E7].Resize(k, 100) = mybrrEnd Sub
For i = 2 To UBound(myarr) If myarr(i, 3) = "已完成" Then If mydic.exists(myarr(i, 1)) Then mydic(myarr(i, 1)) = mydic(myarr(i, 1)) & "@" & myarr(i, 2) Else mydic(myarr(i, 1)) = myarr(i, 2) End If End IfNext i
第5-13行代码：创建字典。以地区为键，并对同一地区下标记为“已完成”的姓名进行合并后，作为键值。
ReDim mybrr(1 To mydic.Count, 1 To 100)
第14行代码：重新定义动态数组mybrr。 For Each d In mydic.keys k = k + 1 mybrr(k, 1) = Split(d, "@")(0) For i = 0 To UBound(Split(mydic(d), "@")) mybrr(k, i + 2) = Split(mydic(d), "@")(i) Next iNext
第15-21行代码：对动态数组赋值。数组的第一列赋值地区；数组的其它列依次赋值用split函数拆分出来的对应的人名。 下面这段代码是群友小白大佬的分享。这段代码也是利用字典+数组来完成的。 完整代码如下： Sub test()Dim arr, dic As Object, m, resSet dic = CreateObject("scripting.dictionary")arr = Range("A1").CurrentRegion.ValueReDim res(1 To 100, 1 To 100)For i = 1 To UBound(arr) If arr(i, 3) = "已完成" Then If dic.exists(arr(i, 1) & "-r") = False Then m = m + 1 dic(arr(i, 1) & "-r") = m res(dic(arr(i, 1) & "-r"), 1) = arr(i, 1) End If dic(arr(i, 1) & "-c") = dic(arr(i, 1) & "-c") + 1 res(dic(arr(i, 1) & "-r"), dic(arr(i, 1) & "-c") + 1) = arr(i, 2) End IfNext iRange("E11").Resize(m, UBound(arr)) = resEnd Sub
If dic.exists(arr(i, 1) & "-r") = False Then m = m + 1 dic(arr(i, 1) & "-r") = m res(dic(arr(i, 1) & "-r"), 1) = arr(i, 1)End If
第8-12行代码：如果姓名不在字典中，就对变量m加1，同时对键“arr(i, 1) & "-r"”赋值为m，再对数组res第1行第1列赋值对应的姓名。 dic(arr(i, 1) & "-c") = dic(arr(i, 1) & "-c") + 1
第13行代码：对键“arr(i, 1) & "-c"”赋值。 这里的dic(arr(i, 1) & "-r")和dic(arr(i, 1) & "-c")分别控制着数组res中“行”和“列”方向上的数据录入。由于通过字典的行数进行，即便是源数据中地区的排列是混乱的，也不影响最终的结果。 完整代码如下： Sub 归类() Dim myarr As Variant, mydic As Object, i, m, n, mybrr myarr = Range("A1").CurrentRegion Set mydic = CreateObject("scripting.dictionary") ReDim mybrr(1 To 10, 1 To 10) For i = 1 To UBound(myarr) If myarr(i, 3) = "已完成" Then If Not mydic.exists(myarr(i, 1)) Then mydic(myarr(i, 1)) = myarr(i, 1): m = m + 1: n = 0 n = n + 1 mybrr(m, 1) = myarr(i, 1): mybrr(m, n + 1) = myarr(i, 2) End If Next i [E15].Resize(UBound(mybrr), 10) = mybrrEnd Sub
这段代码的思路和上面第二个的基本上是一样的。只是，利用变量n来替代dic(arr(i, 1) & "-c")，是否在阅读理解上更加容易一些呢？ 本期内容练习文件提取方式： 链接：https://pan.baidu.com/s/1GKBC8HTduwlnD-2nlxw04Q?pwd=qu05好了朋友们，今天和大家分享的内容就是这些了！喜欢我的文章请分享、转发、点赞和收藏吧！如有任何问题可以随时私信我哦！-END-
长按下方二维码关注EXCEL应用之家 面对EXCEL操作问题时不再迷茫无助
|
