Question

我正在使用以下代码 - 感谢@bonCodigo

Sub groupConcat()
Dim dc As Object
Dim inputArray As Variant
Dim i As Integer

    Set dc = CreateObject("Scripting.Dictionary")
    inputArray = WorksheetFunction.Transpose(Sheets(1).Range("A2:B7").Value)

       '-- assuming you only have two columns - otherwise you need two loops
       For i = LBound(inputArray, 2) To UBound(inputArray, 2)
            If Not dc.Exists(inputArray(1, i)) Then
                dc.Add inputArray(1, i), inputArray(2, i)
            Else
                dc.Item(inputArray(1, i)) = dc.Item(inputArray(1, i)) _
                & "; " & inputArray(2, i)
            End If
       Next i

    '--output into sheet
    Sheets(1).Range("D2").Resize(UBound(dc.keys) + 1) = _
              Application.Transpose(dc.keys)
    Sheets(1).Range("E2").Resize(UBound(dc.items) + 1) = _
              Application.Transpose(dc.items)

    Set dc = Nothing
End Sub

非常优雅的解决方案。不幸的是，我遇到了使用Transpose方法的限制。我有很长的字符串，我想使用上面的代码连接。任何帮助将不胜感激。

此致

Answer 1

This also uses a variant array but without the `Transpose`. It will ignore blank values to boot.

It runs by column, then by row

Sub Bagshaw()
Dim allPosts As Variant
Dim allPosts2 As Variant
Dim lngRow As Long
Dim lngCol As Long
Dim lngCnt As Long
Dim objDic As Object

Set objDic = CreateObject("Scripting.Dictionary")
allPosts = Range("A2:B5000").Value2
ReDim allPosts2(1 To UBound(allPosts, 1) * UBound(allPosts, 2), 1 To 1)

 For lngCol = 1 To UBound(allPosts, 2)
    For lngRow = 1 To UBound(allPosts, 1)
        If Not objDic.exists(allPosts(lngRow, lngCol)) Then
            If Len(allPosts(lngRow, lngCol)) > 0 Then
                objDic.Add allPosts(lngRow, lngCol), 1
                lngCnt = lngCnt + 1
                allPosts2(lngCnt, 1) = allPosts(lngRow, lngCol)
             End If
        End If
    Next
Next
Range("D2").Resize(UBound(allPosts2, 1)).Value2 = allPosts2
End Sub

Answer 2

Sub groupConcat()
    Dim r As Range
    Dim ro As Range
    Dim myr As Range
    Dim vcompt As Integer

    vcompt = 0

    Set ro = Range(Range("A2"), Range("A2").End(xlDown))

    For i = Range("A2").Row To Range("A2").End(xlDown).Row
        Debug.Print Range("A" & i).Address
        Set myr = ro.Find(what:=Range("A" & i).Value, after:=Range("A2").End(xlDown), Lookat:=xlWhole, SearchDirection:=xlNext)

        If myr Is Nothing Or myr.Address = Range("A" & i).Address Then

            mystr = Range("A" & i).Offset(0, 1).Value
            Set r = Range(Range("A" & i), Range("A2").End(xlDown))

            Set myr = r.Find(what:=Range("A" & i).Value, Lookat:=xlWhole, SearchDirection:=xlNext)
            If Not myr Is Nothing And r.Address <> Range("A2").End(xlDown).Address Then
                Do While myr.Address <> Range("A" & i).Address
                    Debug.Print "r: " & r.Address
                    Debug.Print "myr: " & myr.Address
                    mystr = mystr & "; " & myr.Offset(0, 1).Value
                    Set myr = r.FindNext(myr)
                Loop
            End If

            Range("D" & 2 + vcompt).Value = Range("A" & i).Value
            Range("D" & 2 + vcompt).Offset(0, 1).Value = mystr
            vcompt = vcompt + 1

        End If

    Next i

End Sub

在没有使用Transpose的情况下重复时连接单元格

2 个答案: