楼主
kevinchengcw |
Q: 如何利用vba代码通过采集数据并多次整理得到特定格式数据结果？
注: 源数据与结果数据示例如下图所示。
A: 代码如下：- Sub test()
- Dim Arr, Arr2, Result, Result2, Dic As Object, N&, I&, Str$
- Arr = Worksheets("gh").[a1].CurrentRegion.Value '将两个工作表的源数据区域放入数组中
- Arr2 = Worksheets("abits").[a1].CurrentRegion.Value
- Set Dic = CreateObject("scripting.dictionary") '创建字典项目,用于存放各个字段存于数组中的位置
- With CreateObject("vbscript.regexp") '创建正则,用于提取特定文本
- .Global = True '全局有效
- .Pattern = "[^()]+?(?=\))" '提取括号中内容
- ReDim Result(1 To 5, 1 To 1) '初始化结果数组
- For N = LBound(Arr) + 1 To UBound(Arr) '循环第一个源数据数组
- If Trim(Arr(N, 2)) <> "" Then '如果是有效字段,则
- If Dic.exists(Arr(N, 2)) Then '判断字典中是否有该字段,如果有,将内容串接到结果数组中的指定位置
- Result(1, Dic(Arr(N, 2))) = Result(1, Dic(Arr(N, 2))) & "/" & Evaluate(.Execute(Arr(N, 3))(0).Value)
- Result(2, Dic(Arr(N, 2))) = Result(2, Dic(Arr(N, 2))) & "+" & Split(Arr(N, 3), "(")(0) & "M"
- Else '如果没有,则判断数组最大下标是否已使用,如果已使用,则为数组增加一列
- I = UBound(Result, 2)
- If Result(1, I) <> "" Then
- I = I + 1
- ReDim Preserve Result(1 To 5, 1 To I)
- End If
- Result(1, I) = Evaluate(.Execute(Arr(N, 3))(0).Value) '计算得到的版式的结果,放入数组指定位置
- Result(2, I) = Split(Arr(N, 3), "(")(0) & "M" '将另一结果加上后缀存入数组中
- Dic.Add Arr(N, 2), I '添加该字段的字典项,记录下数组下标位置
- End If
- End If
- Next N
- For N = LBound(Arr2) + 1 To UBound(Arr2) '循环第二个数据源数组
- If Trim(Arr2(N, 4)) <> "" Then '如果是有效数据
- Str = Arr2(N, 4) '将数据赋值给变量
- If Dic.exists(Str) Then '同样判断是否存在该数据项并进行同上一过程类似的操作
- Result(3, Dic(Str)) = Arr2(N, 1)
- Result(4, Dic(Str)) = Arr2(N, 2)
- Result(5, Dic(Str)) = Arr2(N, 3)
- End If
- Else
- Result(5, Dic(Str)) = Result(5, Dic(Str)) & "," & Arr2(N, 3)
- End If
- Next N
- End With
- ReDim Result2(LBound(Result, 2) To UBound(Result, 2), LBound(Result) To UBound(Result)) '重定义写入到工作表的数组
- For N = LBound(Result2) To UBound(Result2) '循环之前等到的结果,组合整理好最终结果
- Result2(N, 1) = "GSM900 S" & Result(1, N) & "(" & Result(2, N) & ")"
- Result2(N, 2) = Result(3, N)
- Result2(N, 3) = Result(4, N)
- Result2(N, 4) = Result(5, N)
- Next N
- With Worksheets("2") '将结果写入到指定工作表中
- [c2].Resize(Dic.Count, 1) = Application.Transpose(Dic.keys)
- [g2].Resize(UBound(Result2), UBound(Result2, 2)) = Result2
- End With
- Set Dic = Nothing '清空字典项目
- End Sub
详见附件及素材源帖.
 规划方案.rar
|