Visual Basic代码在一个实例中工作但不在另一个实例中

时间:2016-05-17 19:38:33

标签: excel vba debugging

我有一些代码可以合并一列中的重复项,并将相应的相邻数据连接到一个单元格中。我测试了它,它可以工作,但是当我在真实世界数据上运行它时,它会删除连接的数据。我确保两列都是文本形式,而不是公式。我使用虚拟数据独立测试了两个真实世界的列并且它有效。关于它为什么在我的测试中工作而不是真实数据的任何解释或提示?此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

1 个答案:

答案 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