楼主
kevinchengcw |
Q: 如何用vba代码分级查找并显示成品各部件组成清单?
A: 代码如下:- Sub test()
- Dim Arr, Arr2, N&, I&, C&, Dic As Object, Dic2 As Object, Rng As Range, Str$, Str2$
- Arr = Range("B2:E" & Cells(Rows.Count, 2).End(3).Row).Formula '将源数据区域的文本装入数组
- Set Dic = CreateObject("scripting.dictionary") '创建字典项目,字典1用于装载各项数据,字典2用于记录部件组成显示情况
- Set Dic2 = CreateObject("scripting.dictionary")
- For N = LBound(Arr) To UBound(Arr) '循环数组各项
- Str2 = Trim(Arr(N, 3)) '将组成部件的单元格内容去除可能存在的空格后赋值给变量
- If Dic.exists(Str2 & vbTab & "Count") Then '如果字典1中存在该项目的计数项,则计数值加1(key由数据及tab分隔符和"Count"计数关键字组成)
- Dic(Str2 & vbTab & "Count") = Dic(Str2 & vbTab & "Count") + 1
- Else '如果不存在则添加,计数值为1
- Dic(Str2 & vbTab & "Count") = 1
- End If
- Str = Trim(Arr(N, 1)) '将整体部件的单元格内容去除可能存在的空格后赋值给变量
- If Dic.exists(Str) Then '如果已存在该部件,则将组成部件的内容以tab符分隔后串接在item项后,并将组成部件的描述写入由组成部件名及tab分隔符和"Detail"关键字组成的key所对应的item项中
- Dic(Str) = Dic(Str) & vbTab & Arr(N, 3)
- Dic(Str2 & vbTab & "Detail") = Arr(N, 4)
- Else '否则添加该项目,并将组成部件作为item项,同时添加该项及该项目前对应行的组成部件对应的描述
- Dic(Str) = Arr(N, 3)
- Dic(Str & vbTab & "Detail") = Arr(N, 2)
- Dic(Str2 & vbTab & "Detail") = Arr(N, 4)
- End If
- Next N
- If Cells(Rows.Count, "W").End(3).Row > 1 Then '如果W列存在需要查询的数据,则
- Application.ScreenUpdating = False '因为存在大量的单元格操作,故关闭屏幕刷新提高运行速度
- C = 2 '设置偏移起始量,即第一份查询结果写入W列向右偏移2列的位置,即Y列
- Range([w2].Offset(, C), Cells(Rows.Count, Columns.Count)).Clear '清空结果区数据
- For Each Rng In Range("w2:w" & Cells(Rows.Count, "W").End(3).Row) '循环查询区各单元格
- Str = Trim(Rng.Value) '将查询内容去除可能存在的空格后赋值给变量
- If Str <> "" Then '如果是有效数据,则
- If Dic.exists(Str) Then '如果字典中存在该项目,则
- I = 0 '初始化行偏移值为0
- [w2].Offset(, C).Value = Str '将当前查询数据写入结果区第一行
- Do '循环从结果区第一行向下循环直到单元格无数据为止
- Str2 = Trim([w2].Offset(I, C).Formula) '提取单元格有效数据赋值给变量
- If Dic.exists(Str2 & vbTab & "Detail") Then [w2].Offset(I, C + 1) = Dic(Str2 & vbTab & "Detail") '如果存在该数据的描述,则将该描述写入到当前循环到的单元格右侧单元格中
- If Dic.exists(Str2) And Not Dic2.exists(Str2) Then '如果存在该数据且该数据之前未曾列举过组成,则
- Arr2 = Split(Dic(Str2), vbTab) '将该数据对应的组成拆分放入数组中
- If I > 0 Then '如果行数非结果区第一行,则
- With Cells(Rows.Count, [w2].Offset(, C).Column).End(3).Offset(1) '将另有组成的部件单元格列出到当前数据列最下方空白单元格中,并将单元格颜色设置为黄色
- .Formula = Str2
- .Interior.Color = vbYellow
- End With
- End If
- Cells(Rows.Count, [w2].Offset(, C).Column).End(3).Offset(1).Resize(UBound(Arr2) + 1) = Application.Transpose(Arr2) '将组成内容转置到当前列的下方
- Dic2(Str2) = "" '将该项目添加到字典2中,防止再次生成组成
- End If
- If Dic(Str2 & vbTab & "Count") = 1 Then [w2].Offset(I, C + 1).Interior.Color = vbRed '如果在源数据列表中只出现一次,则将对应的描述列单元格设置成红色
- I = I + 1 '下移一行
- Loop While [w2].Offset(I, C) <> "" '循环直到单元格为空值
- C = C + 2 '下一查询结果数据右移两列
- End If
- End If
- Dic2.RemoveAll '清空字典2中项目,以进行新的数据查询
- Next Rng
- Application.ScreenUpdating = True '打开屏幕刷新
- End If
- Set Dic = Nothing '清空字典项目
- Set Dic2 = Nothing
- End Sub
详见附件及素材源帖.
 物料.rar
 该帖已经同步到 |
