Excel 有没有其他方法可以组合相同项的字符串？

我想问一下如何缩短下面的代码？有没有其他方法可以达到同样的效果

Option Explicit
Sub test()
Dim i As Integer
Dim nRow As Integer: nRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To nRow
    If Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) And Cells(i + 2, 1) = Cells(i + 3, 1) And Cells(i + 3, 1) = Cells(i + 4, 1) Then
        Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2) & "/" & Cells(i + 3, 2) & "/" & Cells(i + 4, 2)
        Rows(i + 1 & ":" & i + 4).Delete Shift:=xlShiftUp
    ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) And Cells(i + 2, 1) = Cells(i + 3, 1) Then
        Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2) & "/" & Cells(i + 3, 2)
        Rows(i + 1 & ":" & i + 3).Delete Shift:=xlShiftUp
    ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) Then
        Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2)
        Rows(i + 1 & ":" & i + 2).Delete Shift:=xlShiftUp
    ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) Then
        Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2)
        Rows(i + 1 & ":" & i + 1).Delete Shift:=xlShiftUp
    ElseIf Cells(i, 1) = "" Then
        Exit For
    End If
Next i
End Sub

选项显式
子测试（）
作为整数的Dim i
Dim nRow作为整数：nRow=单元格（Rows.Count，1）。结束（xlUp）。行
对于i=2到nRow
如果单元格（i，1）”和单元格（i，1）=单元格（i+1，1）和单元格（i+1，1）=单元格（i+2，1）和单元格（i+2，1）=单元格（i+3，1）和单元格（i+3，1）=单元格（i+4，1），则
单元（i，2）=单元（i，2）&“/”和单元（i+1，2）&“/”和单元（i+2，2）&“/”和单元（i+3，2）&“/”和单元（i+4，2）
行（i+1&“：”&i+4）。删除移位：=xlShiftUp
ElseIf Cells（i，1）”，Cells（i，1）=Cells（i+1，1）和Cells（i+1，1）=Cells（i+2，1）和Cells（i+2，1）=Cells（i+3，1），然后
单元（i，2）=单元（i，2）&“/”和单元（i+1，2）&“/”和单元（i+2，2）&“/”和单元（i+3，2）
行（i+1&“：”&i+3）。删除移位：=xlShiftUp
ElseIf Cells（i，1）”，Cells（i，1）=Cells（i+1，1）和Cells（i+1，1）=Cells（i+2，1），然后
单元格（i，2）=单元格（i，2）&“/”和单元格（i+1，2）&“/”和单元格（i+2，2）
行（i+1&“：”&i+2）。删除移位：=xlShiftUp
ElseIf Cells（i，1）”，Cells（i，1）=Cells（i+1，1），然后
单元（i，2）=单元（i，2）&“/”和单元（i+1，2）
行（i+1&“：”&i+1）。删除移位：=xlShiftUp
ElseIf细胞（i，1）=“然后
退出
如果结束
接下来我
端接头

---

谢谢大家!

以下是基于词典的方法，应该适合您

Public Sub RearrangeData()
    Dim objDic As Object
    Dim varRng
    Dim i As Long
    Set objDic = CreateObject("Scripting.Dictionary")
    objDic.CompareMode = vbTextCompare '\\ change this if you need it case sensitive
    varRng = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).Value
    For i = LBound(varRng) To UBound(varRng)
        If objDic.Exists(varRng(i, 1)) Then
            objDic.Item(varRng(i, 1)) = objDic.Item(varRng(i, 1)) & "/" & varRng(i, 2)
        Else
            objDic.Add varRng(i, 1), varRng(i, 2)
        End If
    Next i
    Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).ClearContents
    Range("A2").Resize(objDic.Count, 1).Value = Application.Transpose(objDic.Keys)
    Range("B2").Resize(objDic.Count, 1).Value = Application.Transpose(objDic.Items)
    Set objDic = Nothing
End Sub

---

这里有一个基于

词典的方法应该适合您

Public Sub RearrangeData()
    Dim objDic As Object
    Dim varRng
    Dim i As Long
    Set objDic = CreateObject("Scripting.Dictionary")
    objDic.CompareMode = vbTextCompare '\\ change this if you need it case sensitive
    varRng = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).Value
    For i = LBound(varRng) To UBound(varRng)
        If objDic.Exists(varRng(i, 1)) Then
            objDic.Item(varRng(i, 1)) = objDic.Item(varRng(i, 1)) & "/" & varRng(i, 2)
        Else
            objDic.Add varRng(i, 1), varRng(i, 2)
        End If
    Next i
    Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).ClearContents
    Range("A2").Resize(objDic.Count, 1).Value = Application.Transpose(objDic.Keys)
    Range("B2").Resize(objDic.Count, 1).Value = Application.Transpose(objDic.Items)
    Set objDic = Nothing
End Sub

这里是另一种字典方法（不需要添加引用）

顺便说一句，如果您需要组合来自更多列的字符串，您可以使用

Option Explicit

Sub strings()
    Dim data As Variant, key As Variant
    Dim i As Long, iCol As Long

    With Range("A1").CurrentRegion
        With .Resize(.Rows.Count - 1).Offset(1)
            data = .Value
            .ClearContents
        End With
    End With

    With CreateObject("Scripting.Dictionary")
        For iCol = 2 To UBound(data, 2)
            For i = 1 To UBound(data)
                .Item(data(i, 1)) = Trim(.Item(data(i, 1)) & " " & data(i, iCol))
            Next
            Range("A2").Resize(.Count) = Application.Transpose(.Keys)
            Range("A2").Resize(.Count).Offset(, iCol - 1) = Application.Transpose(.Items)
            .RemoveAll
        Next
    End With
    Range("a1").CurrentRegion.Replace what:=" ", replacement:="/", lookat:=xlPart
End Sub

这里是另一种字典方法（不需要添加引用）

顺便说一句，如果您需要组合来自更多列的字符串，您可以使用

Option Explicit

Sub strings()
    Dim data As Variant, key As Variant
    Dim i As Long, iCol As Long

    With Range("A1").CurrentRegion
        With .Resize(.Rows.Count - 1).Offset(1)
            data = .Value
            .ClearContents
        End With
    End With

    With CreateObject("Scripting.Dictionary")
        For iCol = 2 To UBound(data, 2)
            For i = 1 To UBound(data)
                .Item(data(i, 1)) = Trim(.Item(data(i, 1)) & " " & data(i, iCol))
            Next
            Range("A2").Resize(.Count) = Application.Transpose(.Keys)
            Range("A2").Resize(.Count).Offset(, iCol - 1) = Application.Transpose(.Items)
            .RemoveAll
        Next
    End With
    Range("a1").CurrentRegion.Replace what:=" ", replacement:="/", lookat:=xlPart
End Sub

使用
Dictionary
对象来实现这一点。代码越短并不一定意味着代码越好。此问题的一些好解决方案的行数与您已有的行数相似。请使用
Dictionary
object来实现这一点。代码越短并不一定意味着代码越好。这个问题的一些好的解决方案将超过你已经拥有的相同行数。删除我的基本相同，而你的设法首先发布！对于Application.Transpose（objDic.Items），您会得到+1NIce@shrivallabha.redij非常感谢。这段代码真的很棒。如果还有一列需要连接字符串，如何连接？@Drager，谢谢您的反馈。请通过编辑question.@shrivallabha.redij显示示例输入和输出，如图所示。谢谢删除了我的，因为基本上是一样的，你的设法张贴第一！对于Application.Transpose（objDic.Items），您会得到+1NIce@shrivallabha.redij非常感谢。这段代码真的很棒。如果还有一列需要连接字符串，如何连接？@Drager，谢谢您的反馈。请通过编辑question.@shrivallabha.redij显示示例输入和输出，如图所示。谢谢@德拉格我不是想从Shrivalabha redij那里窃取“公认的答案”。所以，请选择最佳答案，只考虑你原来的问题，而不是你在评论后添加和删除的后续增强。你的答案和SyValLabHaRayJ回答都符合我的要求。您的代码可以用于更多的列，所以最后我认为您的答案更好。@Drager我不是想从Shrivalabha redij那里窃取“已接受的答案”。所以，请选择最佳答案，只考虑你原来的问题，而不是你在评论后添加和删除的后续增强。你的答案和SyValLabHaRayJ回答都符合我的要求。您的代码可以用于更多的列，所以最后我认为您的答案更好。