ビジュアル基本コードは1つのインスタンスで動作しますが、別のインスタンスでは動作しません。

Question

私は、ある列から重複をマージし、対応する隣接するデータをセルに連結するコードを持っています。私はそれを試して、それは動作しますが、実際のデータで実行すると、連結されたデータが削除されます。私は、両方の列が数式形式ではなくテキスト形式であることを確認しました。ダミーデータを使用して実世界の列を個別にテストしていました。なぜ私のテストでは動作していますが、実際のデータでは動かないのかについての説明やヒントはありますか？この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 

Answer 1

それは辞書項目は転置が処理するには大きすぎることが可能です。代わりにこれを試してください -

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