楼主
kevinchengcw |
Q: 如何用vba代码将对应的域名网址及相关数据拆分到对应的工作表中？
A: 代码如下：
- Option Compare Text '以文本的方式比较，排除大小写的影响
- Sub test()
- Dim Dic, Arr, Arr2, N&, I&
- Application.ScreenUpdating = False '因需对多个工作表进行处理，运行时间较长，关闭屏幕刷新以提高速度
- Set Dic = CreateObject("scripting.dictionary") '创建字典项目
- For N = 3 To Worksheets.Count '取得要放入域名结果的各个表名
- If Not Dic.exists(Worksheets(N).Name) Then Dic.Add Worksheets(N).Name, ""
- Next N
- Arr = Dic.keys '将域名清单放入数组Arr中
- Dic.RemoveAll '清空字典内容，以便进行下一步处理
- With Worksheets(1) '从源数据表中取出各个项目添加到字典中
- For N = 2 To .Cells(.Rows.Count, 1).End(3).Row
- If Not Dic.exists(.Cells(N, 1).Value) Then Dic.Add .Cells(N, 1).Value, Join(Application.Transpose(Application.Transpose(.Cells(N, 2).Resize(1, 3))), vbTab)
- Next N
- End With
- Arr2 = Dic.keys '将字典的keys清单赋值给数组Arr2
- For I = LBound(Arr) To UBound(Arr) '循环域名工作表清单进行相应处理
- With Worksheets(Arr(I))
- .Rows("2:" & .Rows.Count).ClearContents '清空现有数据
- .Columns(3).NumberFormatLocal = "0.00%" '设置C列数字格式
- For N = LBound(Arr2) To UBound(Arr2) '循环字典keys各项
- If Arr2(N) = Arr(I) Or Split(Arr2(N), "/")(0) Like "*" & Arr(I) & ".*" Then '如果域名等于当前工作表名或域名关键字与表名相同则
- .Cells(.Rows.Count, 1).End(3).Offset(1, 0) = Arr2(N) '当前工作表的最后一行数据下一行A列写入当前key值数据
- .Cells(.Rows.Count, 1).End(3).Offset(0, 1).Resize(1, 3) = Split(Dic(Arr2(N)), vbTab) 'B列到D列写入item项对应的数据
- Dic.Remove (Arr2(N)) '删除当前key值对应的字典项
- End If
- Next N
- Intersect(.UsedRange, .Columns("B:D")) = Intersect(.UsedRange, .Columns("B:D")).Value '因split拆分出的数据为文本，故对数据区重新赋值一次转换为数值（相当于粘贴数值操作）
- End With
- Next I
- With Worksheets("没排名") '对“没排名”的工作表的操作如下
- .Rows("2:" & .Rows.Count).ClearContents '清空原有数据
- .Columns(3).NumberFormatLocal = "0.00%" '同样设置C列的数字格式
- If Dic.Count > 0 Then '如果字典中还有剩余的项，则
- Arr = Dic.keys '将剩余的项目赋值给数组Arr
- For N = LBound(Arr) To UBound(Arr) '循环数组各项取出对应的key值，并将key值与item值写入对应单元格中
- .Cells(N + 2, 1) = Arr(N)
- .Cells(N + 2, 2).Resize(1, 3) = Split(Dic(Arr(N)), vbTab)
- Next N
- Intersect(.UsedRange, .Columns("B:D")) = Intersect(.UsedRange, .Columns("B:D")).Value '将对应列的文本转换成数值
- End If
- End With
- Set Dic = Nothing '清空字典项目
- Application.ScreenUpdating = True '打开屏幕刷新
- MsgBox "处理完成" '显示提示信息
- End Sub
附示例文件。
 GA内容网址.rar
|