作者：绿色风
分类：
时间：2022-08-17
浏览：138
楼主
kevinchengcw |
Q: 如何用vba代码根据理论数据标识出实际数据中的多余数据？
A: 实际数据中存在与理论数据相同的数据，也有不同的数据，根据理论数据系列规律，找出相同点，并将不同数据中的实际数据中最接近理论数据的项定义为序列内容，将其他不符合的标示为黄色，代码如下：- Sub test()
- Dim Dic As Object, Dic2 As Object, Arr, Arr2, N&, I&, Rng As Range
- Arr = Range("A2:A" & Cells(Rows.Count, 1).End(3).Row) '提取理论数据区到数组中
- Set Dic = CreateObject("scripting.dictionary") '定义字典项目,用于存储及比较数据,提高效率
- Set Dic2 = CreateObject("scripting.dictionary")
- For N = LBound(Arr) To UBound(Arr) '将理论数据内容存入字典中
- Dic(CStr(Arr(N, 1))) = ""
- Next N
- Arr2 = Range("D2:D" & Cells(Rows.Count, 4).End(3).Row) '将实际数据存入数组中
- For I = LBound(Arr2) To UBound(Arr2) '循环实际数据,并从字典中去除已存在项
- If Dic.exists(CStr(Arr2(I, 1))) Then
- Dic.Remove CStr(Arr2(I, 1))
- Arr2(I, 1) = ""
- Else '理论数据中未存在的数据存入字典2中
- Dic2.Add CStr(Arr2(I, 1)), ""
- End If
- Next I
- Arr = Dic.keys '取得处理后的字典1和字典2的内容到数组中
- For N = LBound(Arr) To UBound(Arr) '循环剩余未出现的理论数据
- Arr2 = Dic2.keys
- For I = LBound(Arr2) To UBound(Arr2) - 1 '循环剩余的实际数据
- If Arr2(I) < Arr(N) And Arr2(I + 1) > Arr(N) Then '如果当前项小于当前理论数据且当前项的下一项大于当前理论项数据
- If Abs(Arr2(I) - Arr(N)) > Abs(Arr2(I + 1) - Arr(N)) Then '判断两个值与当前理论项差值的大小,并将差值小的项从字典中删除(因可能有提前删除的情况,故删除前先判断是否存在)
- If Dic2.exists(CStr(Arr2(I + 1))) Then Dic2.Remove CStr(Arr2(I + 1))
- Else
- If Dic2.exists(CStr(Arr2(I))) Then Dic2.Remove CStr(Arr2(I))
- End If
- Exit For '情况实现后,退出循环
- End If
- Next I
- Next N
- Columns(4).Interior.ColorIndex = xlNone '将实际数据列底色清除
- For Each Rng In Range("D2:D" & Cells(Rows.Count, 4).End(3).Row) '循环实际数据列数据区,如果字典中有该数据,则底色变黄(即多余数据项)
- If Dic2.exists(Rng.Text) Then Rng.Interior.Color = vbYellow
- Next Rng
- Set Dic = Nothing '清空字典项目
- Set Dic2 = Nothing
- End Sub
详见附件及素材源帖。
 示例.rar
|
2楼
tangwei94054 |
老师，支持你哟！谢谢 |
免责声明
有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素，
经与ExcelTip.Net站长Apolloh商议并征得其同意，
现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示，
供有需要的人士查询使用，也慰缅曾经的论坛时代。
所示各个帖子的原作者如对版权有异议，
可与本人沟通提出，或于本站点留言，我们会尽快处理。
在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一