Microsoft VBA Excel 去重小工具

问题简述

在本工作表中,A1:B3单元格样式如下,通过名称管理器B列的单元格被命名为"LinkFile"、"SheetName"、"InputArea",请实现以下功能:读取Excel文件中的数据,去除重复的数据,并记录每个数据项最后一次出现的位置,最后将结果输出到当前工作表中。

A B
1 Link File:
2 Sheet Name:
3 Input Area:

代码描述

第一步:

读取:输入一个xls表格文件的地址到"LinkFile"、该文件内工作表名称到"SheetName"和需要读取数据的范围(例如A2:A102)到"InputArea",根据指定范围在该文件内指定工作表中读取所有数据;
第二步:

去重和获得索引:上一步获取的数据中存在重复,因此只需要保留唯一值,根据唯一值获得该值最后一次出现在读取数据范围的行列位置信息;
第三步:

输出:在本工作表中,在"InputArea"单元格下两行开始输出从上一步得到的单元格数据和对应的行列信息,也就是从A5开始输入单元格数据,B5开始输入对应的行列信息。

vba 复制代码
Sub ProcessData()
    Dim srcWb As Workbook
    Dim ws As Worksheet, srcWs As Worksheet
    Dim linkFile As String, sheetName As String, inputArea As String
    Dim rng As Range, cell As Range
    Dim dict As Object
    Dim outputRow As Long
    
    ' 创建字典来存储唯一值和对应的最后位置
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 获取当前活动的工作表
    Set ws = ThisWorkbook.ActiveSheet
    
    ' 读取工作表中的相关数据
    linkFile = ws.Range("LinkFile").Value
    sheetName = ws.Range("SheetName").Value
    inputArea = ws.Range("InputArea").Value
    
    ' 打开源数据文件
    Set srcWb = Workbooks.Open(linkFile)
    Set srcWs = srcWb.Sheets(sheetName)
    
    ' 获取指定范围
    Set rng = srcWs.Range(inputArea)
    
    ' 遍历范围,收集数据
    For Each cell In rng
        If Not dict.Exists(cell.Value) Then
            dict.Add cell.Value, cell.Address(False, False)
        Else
            dict(cell.Value) = cell.Address(False, False)  ' 更新为最后出现的位置
        End If
    Next cell
    
    ' 关闭源数据文件
    srcWb.Close False
    
    ' 输出结果
    outputRow = ws.Range("InputArea").Row + 2
    For Each key In dict.Keys
        ws.Cells(outputRow, 1).Value = key
        ws.Cells(outputRow, 2).Value = dict(key)
        outputRow = outputRow + 1
    Next
    
    MsgBox "数据处理完毕!"
End Sub

English:

vba 复制代码
Sub ProcessData()
    Dim srcWb As Workbook
    Dim ws As Worksheet, srcWs As Worksheet
    Dim linkFile As String, sheetName As String, inputArea As String
    Dim rng As Range, cell As Range
    Dim dict As Object
    Dim outputRow As Long
    
    ' Create a dictionary to store unique values and corresponding last positions
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' Get the currently active worksheet
    Set ws = ThisWorkbook.ActiveSheet
    
    ' Read relevant data from the worksheet
    linkFile = ws.Range("LinkFile").Value
    sheetName = ws.Range("SheetName").Value
    inputArea = ws.Range("InputArea").Value
    
    ' Open the source data file
    Set srcWb = Workbooks.Open(linkFile)
    Set srcWs = srcWb.Sheets(sheetName)
    
    ' Get the specified range
    Set rng = srcWs.Range(inputArea)
    
    ' Iterate over the range, collecting data
    For Each cell In rng
        If Not dict.Exists(cell.Value) Then
            dict.Add cell.Value, cell.Address(False, False)
        Else
            dict(cell.Value) = cell.Address(False, False)  ' Update to the last position of occurrence
        End If
    Next cell
    
    ' Close the source data file
    srcWb.Close False
    
    ' Output the results
    outputRow = ws.Range("InputArea").Row + 2
    For Each key In dict.Keys
        ws.Cells(outputRow, 1).Value = key
        ws.Cells(outputRow, 2).Value = dict(key)
        outputRow = outputRow + 1
    Next
    
    MsgBox "Data processed successfully!"
End Sub

总结

相关推荐
Coding_Doggy13 小时前
苍穹外卖Day12 | Apache POI、导出Excel报表、HttpServletResponse、工作台
excel
l1t1 天前
张泽鹏先生手搓的纯ANSI处理UTF-8与美团龙猫调用expat库读取Excel xml对比测试
xml·人工智能·excel·utf8·expat
一点都不方女士1 天前
《无畏契约》游戏报错“缺少DirectX”?5种解决方案(附DirectX修复工具)
windows·游戏·microsoft·动态链接库·directx·运行库
Source.Liu1 天前
【Python自动化】 21 Pandas Excel 操作完整指南
python·excel·pandas
会飞的小菠菜2 天前
如何根据Excel数据表生成多个合同、工作证、录取通知书等word文件?
word·excel·模板·数据表·生成文件
anlpsonline2 天前
安全产业 出海行动 | 安贝斯受邀参加第六届非传统安全(杭州)国际论坛:靠近国际前沿 拓宽国际视野
microsoft
Access开发易登软件2 天前
Access开发导出PDF的N种姿势,你get了吗?
后端·低代码·pdf·excel·vba·access·access开发
課代表2 天前
VBA 中的 Excel 工作表函数
excel·vba·函数·对象·属性·range·静态变量
UrbanJazzerati2 天前
掌握 xlwings 的 used_range:高效处理 Excel 数据区域
python·面试·excel
seegaler2 天前
WrenAI:开源革命,重塑商业智能未来
人工智能·microsoft·ai