如何循环遍历 Excel VBA 中的列表并连接两列中的唯一和重复 ID？

Question

连接 Excel 范围...

嗨，我希望有人能帮我解决我的问题。如果我没有正确解释这一点，请原谅我，但我的 VBA 知识有限。我提供了以下解释和示例，希望能更好地说明我想要实现的目标。

这是我试图解释问题的尝试：

我正在尝试遍历 A 列中的 ID 列表，并返回 B 列中唯一/不同 ID 的 ID 字符串的（最后或第 5 个字符）。

接下来，我想查看 ID 字符串的重复 ID（基于前 4 个字符），并在与第一个重复项相邻的单元格中返回 ID 字符串的最后一个（或第 5 个字符）（请参见下图）。这个想法是将每个重复值中解析的（最后一个或第 5 个字符）连接起来，并将它们返回到 B 列相邻的单元格中（请参见下图）。

希望这是有道理的。非常感谢任何帮助！

我尝试使用此处找到的 VBA 示例，但无法解决我的问题：

https://trumpexcel.com/concatenate-excel-ranges/

Answer 1

加入尾随字符

Sub JoinUniqueTrailingChars()
    
    Const WS_NAME As String = "Sheet1"
    Const SRC_FIRST_CELL As String = "A2"
    Const DST_COLUMN As String = "B"
    Const CHAR_COUNT As Long = 1
    Const CHAR_DELIMITER As String = ", "
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Sheets(WS_NAME)
    
    Dim srg As Range
    
    With ws.Range(SRC_FIRST_CELL)
        Set srg = ws.Range(.Cells, ws.Cells(ws.Rows.Count, .Column).End(xlUp))
    End With
    
    Dim rCount As Long: rCount = srg.Rows.Count
    
    Dim sData()
    
    If rCount = 1 Then
        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
    Else
        sData = srg.Value
    End If
    
    Dim dData(): ReDim dData(1 To rCount, 1 To 1)
    
    Dim rDict As Object: Set rDict = CreateObject("Scripting.Dictionary")
    rDict.CompareMode = vbTextCompare
    
    Dim cDict As Object: Set cDict = CreateObject("Scripting.Dictionary")
    cDict.CompareMode = vbTextCompare
    
    Dim r As Long, sStr As String, dlStr As String, drStr As String
    
    For r = 1 To rCount
        sStr = CStr(sData(r, 1))
        If Len(sStr) >= CHAR_COUNT Then
            dlStr = Left(sStr, Len(sStr) - CHAR_COUNT)
            drStr = Right(sStr, CHAR_COUNT)
            If Not rDict.Exists(dlStr) Then
                rDict(dlStr) = r
                Set cDict(dlStr) = CreateObject("Scripting.Dictionary")
                cDict(dlStr).CompareMode = vbTextCompare
                cDict(dlStr)(drStr) = Empty
            Else
                If Not cDict(dlStr).Exists(drStr) Then
                    cDict(dlStr)(drStr) = Empty
                End If
            End If
        End If
    Next r
    
    Dim rKey
    
    For Each rKey In rDict.Keys
        dData(rDict(rKey), 1) = Join(cDict(rKey).Keys, CHAR_DELIMITER)
    Next rKey
    
    Dim drg As Range: Set drg = srg.EntireRow.Columns(DST_COLUMN)
    
    drg.Value = dData
    
    MsgBox "Unique trailing characters joined.", vbInformation

End Sub

Answer 2

另一种方式，仅当 ID 值始终为 5 个字符时 ....

Sub test()
Dim rg As Range, cell As Range, c As Range, d As Range
Dim arr, fa As String

With Sheets("Sheet1")
Set rg = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
End With

Set arr = CreateObject("scripting.dictionary")
For Each cell In rg: arr.Item(Left(cell.Value, 4)) = 1: Next

    For Each el In arr
    Set c = Columns(1).Find(el, lookat:=xlPart, after:=Cells(1, 1))
    fa = c.Address
    Set d = c.Offset(0, 1): d.Value = Right(c.Value, 1)
        Do
            Set c = Columns(1).Find(el, lookat:=xlPart, after:=c)
            If d.Find(Right(c.Value, 1), lookat:=xlPart) Is Nothing _
            Then d.Value = d.Value & ", " & Right(c.Value, 1)
        Loop Until c.Address = fa
    Next

End Sub

子创建范围变量从 A2 到数据为 rg 的任何最后一行。
然后它循环到 rg 中的每个单元格以创建一个唯一值，该值是循环单元格值左侧的前四个字符作为 arr 变量。

然后它循环到 arr.中的每个元素
获取A列中第一个找到的值为循环元素的单元格作为c变量，然后将c.offset（0,1）的范围设置为d变量并用c值的最后一个字符填充d。

然后循环查找A列中的下一个元素，并检查下一个找到的单元格最后一个字符值是否不存在于d中，它将最后一个字符添加到d中。

--->