在没有使用转置的情况下连接单元格

我正在使用下面的代码 – 谢谢@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 

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

问候

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