我有一些代码可以合并一列中的重复项,并将相应的相邻数据连接到一个单元格中。我测试了它,它可以工作,但是当我在真实世界数据上运行它时,它会删除连接的数据。我确保两列都是文本形式,而不是公式。我使用虚拟数据独立测试了两个真实世界的列并且它有效。关于它为什么在我的测试中工作而不是真实数据的任何解释或提示?此image左侧的数据是真实世界数据。右边的数据是成功测试的一个例子。我还运行了连接空单元和字母的成功测试。
Private Sub CommandButton2_Click()
'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
答案 0 :(得分:0)
字典项目可能太大而无法进行转置处理:请尝试此操作 -
Private Sub CommandButton2_Click()
Dim WorkRng As Range, xTitleId, i, xvalue
Dim Dic As Variant
Dim arr As Variant
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(xvalue) = Dic(xvalue) & " " & arr(i, 2)
Else
Dic(xvalue) = arr(i, 2)
End If
Next
DictToRange Dic, WorkRng.Range("A1").Offset(0, 5)
End Sub
Sub DictToRange(d, rng As Range)
Dim arr(), x As Long, k
ReDim arr(1 To d.Count, 1 To 2)
x = 1
For Each k In d
arr(x, 1) = k
arr(x, 2) = d(k)
x = x + 1
Next k
rng.Cells(1).Resize(d.Count, 2).Value = arr
End Sub