Microsoft VBA Excel 去重+自动化配对信息

问题场景

A列数据中存在很多特别的情况：

中间分隔符为"/"，但是分隔符前后可能存在空格
一个编号可能出现多次，例如示例中6003出现了5次
可能为空，虽然节选的这部分没出现这种情况

B和C列数据中，会出现空格。

A	B	C
6003	AAA	L7
6003/ 6007/6001	AA	L6
6000/6003/6009	A	L1
6000 / 6003	AA	L8
6003		L9

现在需要在新的Sheet中对原先的Sheet有以下操作：

从不重复的提取出所有编号，例如该节选数据结果是6003、6007、6001、6000、6009
对于提取的编号给予最后一次出现的行号，例如1中对应结果是5，2，2，4，3
根据编号最后一次出现的行号提取B和C的信息，如果不为空则填入想同行的B和C列的信息，如果为空则寻找上一次出现的内容，例如最后一次6003为空，则找到上一次是第4行，输出AA

根据以上信息，示例数据的结果应该是：

A	B	C
6003	AA	L9
6007	AA	L6
6001	AA	L6
6000	AA	L8
6009	A	L1

代码描述

分析和提取每个单元格中的编号。
记录每个编号最后出现的行号以及对应的B和C列数据。
填充新Sheet中的数据，如果B或C列为空，则查找之前的非空数据。

中文版

vba 复制代码

Sub ProcessData()
    Dim wsControl As Worksheet
    Dim WbSource As Workbook
    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim i As Long, j As Long, k As Long
    Dim codes() As String, code As String
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary") ' 创建字典来存储信息
    Dim tempData As Variant
    
    ' 获取当前活动的工作表
    Set wsControl = ThisWorkbook.ActiveSheet

    ' 读取工作表中的相关数据
    linkFile = wsControl.Range("LinkFile").Value
    sheetName = wsControl.Range("SheetName").Value
    inputName = wsControl.Range("InputName").Value
    inputStart = wsControl.Range("InputStart").Value
    inputEnd = wsControl.Range("InputEnd").Value
    
    ' 设置源和目标工作表
    Set WbSource = Workbooks.Open(linkFile)
    Set wsSource = srcWb.Sheets(sheetName)
    Set wsDest = ThisWorkBook.Worksheets.Add
    wsDest.Name = inputName
    
    ' 定义数据的起始行和结束行
    Dim startRow As Long, endRow As Long
    startRow = inputStart
    endRow = inputEnd
    
    ' 遍历所有数据行
    For i = startRow To endRow
        If Trim(wsSource.Cells(i, 1).Value) <> "" Then
            codes = Split(Replace(wsSource.Cells(i, 1).Value, " ", ""), "/")
            For j = LBound(codes) To UBound(codes)
                code = Trim(codes(j))
                ' 更新字典中的信息
                dict(code) = Array(i, Trim(wsSource.Cells(i, 2).Value), Trim(wsSource.Cells(i, 3).Value))
            Next j
        End If
    Next i
    
    ' 将结果写入新的工作表
    k = 5
    For Each key In dict.Keys
        tempData = dict(key)
        ' 检查B和C列是否为空，如果为空，向上查找非空值
        If tempData(1) = "" Or tempData(2) = "" Then
            For j = tempData(0) - 1 To startRow Step -1
                If wsSource.Cells(j, 2).Value <> "" And tempData(1) = "" Then tempData(1) = Trim(wsSource.Cells(j, 2).Value)
                If wsSource.Cells(j, 3).Value <> "" And tempData(2) = "" Then tempData(2) = Trim(wsSource.Cells(j, 3).Value)
                If tempData(1) <> "" And tempData(2) <> "" Then Exit For
            Next j
        End If
        wsDest.Cells(k, 1).Value = key
        wsDest.Cells(k, 2).Value = tempData(1)
        wsDest.Cells(k, 3).Value = tempData(2)
        k += 1
    Next key
    
    ' 关闭源工作簿（如果不需要保存，则不保存）
    WbSource.Close SaveChanges:=False
    ' 自动调整列宽
    wsDest.Columns("A:C").AutoFit
End Sub

英文版

vba 复制代码

Sub ProcessData()
    Dim wsControl As Worksheet
    Dim WbSource As Workbook
    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim i As Long, j As Long, k As Long
    ' Variables to hold codes and dictionaries
    Dim codes() As String, code As String
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary") ' Create dictionary to store information
    
    ' Set the control worksheet to the currently active sheet
    Set wsControl = ThisWorkbook.ActiveSheet

    ' Read necessary data from the control worksheet
    Dim linkFile As String, sheetName As String, inputName As String
    Dim inputStart As Long, inputEnd As Long
    linkFile = wsControl.Range("LinkFile").Value
    sheetName = wsControl.Range("SheetName").Value
    inputName = wsControl.Range("InputName").Value
    inputStart = wsControl.Range("InputStart").Value
    inputEnd = wsControl.Range("InputEnd").Value
    
    ' Open the source workbook and set the source and destination worksheets
    Set WbSource = Workbooks.Open(linkFile)
    Set wsSource = WbSource.Sheets(sheetName)
    Set wsDest = ThisWorkbook.Worksheets.Add
    wsDest.Name = inputName
    
    ' Define the data's start and end rows
    Dim startRow As Long, endRow As Long
    startRow = inputStart
    endRow = inputEnd
    
    ' Iterate through all rows in the data range
    For i = startRow To endRow
        ' Check if the cell in column A is not empty
        If Trim(wsSource.Cells(i, 1).Value) <> "" Then
            ' Split the cell content by "/", removing spaces
            codes = Split(Replace(wsSource.Cells(i, 1).Value, " ", ""), "/")
            For j = LBound(codes) To UBound(codes)
                code = Trim(codes(j))
                ' Update dictionary with new information
                dict(code) = Array(i, Trim(wsSource.Cells(i, 2).Value), Trim(wsSource.Cells(i, 3).Value))
            Next j
        End If
    Next i
    
    ' Write the results to the new worksheet
    k = 5 ' Start writing from row 5
    For Each key In dict.Keys
        tempData = dict(key)
        ' Check if columns B and C are empty, if so, look upwards for non-empty values
        If tempp(1) = "" Or tempData(2) = "" Then
            For j = tempData(0) - 1 To startRow Step -1
                If wsSource.Cells(j, 2).Value <> "" And tempData(1) = "" Then tempData(1) = Trim(wsSource.Cells(j, 2).Value)
                If wsSource.Cells(j, 3).Value <> "" And tempData(2) = "" Then tempData(2) = Trim(wsSource.Cells(j, 3).Value)
                If tempData(1) <> "" And tempData(2) <> "" Then Exit For
            Next j
        End If
        wsDest.Cells(k, 1).Value = key
        wsDest.Cells(k, 2).Value = tempData(1)
        wsDest.Cells(k, 3).Value = tempData(2)
        k += 1
    Next key
    
    ' Close the source workbook without saving changes
    WbSource.Close SaveChanges:=False
    ' AutoFit columns to content
    wsDest.Columns("A:C").AutoFit
End Sub