Question

我有一个数据电子表格，如下所示：

V1 Wht
V1 blck
V1 Red 
V2 Wht
V2 Grn 
V3 prpl

我需要它简化为

V1 wht, blck, red
V2 Wht, grn
V3 prpl

我在网上发现了一个可以执行此操作的宏

Sub CombineRows()
'Update 20131202
Dim WorkRng As Range
Dim Dic As Variant
Dim arr As Variant
On Error Resume Next
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Set Dic = CreateObject("Scripting.Dictionary")
arr = WorkRng.Value
For i = 1 To UBound(arr, 1)
    xvalue = arr(i, 1)
    If Dic.Exists(xvalue) Then
        Dic(arr(i, 1)) = Dic(arr(i, 1)) & ", " & arr(i, 2)
    Else
        Dic(arr(i, 1)) = arr(i, 2)
    End If
Next
Application.ScreenUpdating = False
WorkRng.ClearContents
WorkRng.Range("A1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.keys)
WorkRng.Range("B1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.items)
Application.ScreenUpdating = True
End Sub

但是它仅适用于大约40或更少值的小块。任何更多，sub将粘贴左列中的键的值，但是，项目所在的右列将为空。

有没有办法修改此代码以便能够安全地处理更多数据？

谢谢！

Answer 1

Tranpose的长度限制为255个字符。无论如何，在你的代码中你根本不需要转置数据。删除转置部分，它可以正常工作。

修改：您需要转置键和值。有限制的解决方法。我补充说。代码复制自：https://stackoverflow.com/a/35399740/3961708

   Sub CombineRows()
    Dim WorkRng As Range
    Dim Dic As Variant
    Dim arr As Variant
    Dim arrItems
    Dim arrTest() As String
    Dim i As Long

    On Error Resume Next

    Set WorkRng = Application.Selection
    Set WorkRng = Application.InputBox("Range", "", WorkRng.Address, Type:=8)
    Set Dic = CreateObject("Scripting.Dictionary")
    arr = WorkRng.Value
    For i = 1 To UBound(arr, 1)
        'xvalue = arr(i, 1)
        If Dic.Exists(arr(i, 1)) Then
            Dic(arr(i, 1)) = Dic(arr(i, 1)) & ", " & arr(i, 2)
        Else
            Dic(arr(i, 1)) = arr(i, 2)
        End If
    Next
    Application.ScreenUpdating = False
    WorkRng.ClearContents
    WorkRng.Range("A1").Resize(Dic.Count, 1) = TR(Dic.keys)

    '/* Check here. Transpose has a limit on 255 chars.
    arrItems = Dic.items
    arrTest = Application.Transpose(arrItems) '/ Put thi sin watch window and it will be blank if the value length is more than 255 chars.

    WorkRng.Range("B1").Resize(Dic.Count, 1) = TR(arrItems)
    Application.ScreenUpdating = True


End Sub

'/ Code copied from : https://stackoverflow.com/a/35399740/3961708
Function TR(arrIn) As String()
    Dim arrOut() As String, r As Long, ln As Long, i As Long

    ln = (UBound(arrIn) - LBound(arrIn)) + 1
    ReDim arrOut(1 To ln, 1 To 1)
    i = 1
    For r = LBound(arrIn) To UBound(arrIn)
        arrOut(i, 1) = arrIn(r)
        i = i + 1
    Next r
    TR = arrOut

End Function

Answer 2

我知道@cyboashu已经回答了，但是请你试试这段代码，看看它是否适用于你的大量数据：

Sub CombineRows()
    'Update 20131202
    Dim WorkRng As Range
    Dim Dic As Variant
    Dim arr As Variant
    On Error Resume Next
    Set WorkRng = Application.Selection
    Set Dic = CreateObject("Scripting.Dictionary")
    arr = WorkRng.Value
    For i = 1 To UBound(arr, 1)
        xvalue = arr(i, 1)
        If Dic.Exists(xvalue) Then
            Dic(arr(i, 1)) = Dic(arr(i, 1)) & ", " & arr(i, 2)
        Else
            Dic(arr(i, 1)) = arr(i, 2)
        End If
    Next
    Application.ScreenUpdating = False
    WorkRng.ClearContents
    i = 1
    'Assuming your data is in column A and B
    For Each Value In Dic.Keys
        Cells(i, 1).Value = Value
        Cells(i, 2).Value = Dic(Value)
        i = i + 1
    Next

    Application.ScreenUpdating = True
End Sub

行组合宏删除数据的问题

2 个答案: