問題與行結合宏觀刪除數據

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個值或更小的小塊。任何更多的東西和子將粘貼在左列的鍵的值，但是，項目應該在的右列將是空白的。

有什麼辦法可以修改這段代碼，以便能夠安全地處理更多的數據？

謝謝！

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