How do I output the same type of value in VBA next to the same value?

user_9983523 0
Viewed 61

I want to use VBA to get the values of columns A and B and output them to columns C and D as below.

  1. Same names in column A are made into one and output to column C.
  2. Same values in column B are kept as one and output side by side in column D.
A B C D
Suzuki 123 Suzuki 123, 456
Suzuki 456 Kato 789
Suzuki 456 SAto 100
Kato 789
Kato 789
SAto 100

I'm able to get the same value to one with researching on the internet. However, I'm unable to output the values in column B side by side.

Here is the code I made myself to combine the same values into one. Please let me know if you can modify my code or if you have a better way to write the code.

VBA

Sub sample()

    Dim Dic, i As Integer, name As String
    Dim order_number As Long
    Set Dic = CreateObject("Scripting.Dictionary") 'Key(キー)とItem(データ)をセットで格納して、リストなどを作成するときに使用。Pythonでいうところのたぶん辞書型

    On Error Resume Next
        
        For i = 1 To 10
        
            name = Cells(i, 1).Value '荷受人の列の名前を1つずつ取得
            order_number = Cells(i, 2).Value '注文番号を1つずつ取得
            
            Dic.Add name, order_number ' Dicに追加していく

        Next i
      
        ' 出力
        For i = 0 To Dic.Count - 1
            mykeys = Dic.Keys
            myItems = Dic.Items
            Range("C" & i + 1).Value = mykeys(i)
            Range("D" & i + 1).Value = myItems(i)
        
            'オブジェクトを開放する
            Set Dic = Nothing

        Next i

End Sub

↓ My code output

A B C D
Suzuki 123 Suzuki 123
Suzuki 456 Kato 789
Suzuki 456 Sato 100
Kato 789
Kato 789
Sato 100
ms-office vba excel
2 Answers

You only ever call Add on the dictionary - you need to check to see if the dictionary already has name as a key, and either Add a new key or update the existing value.

Try this:

Sub sample()
    Dim dic As Object, i As Long, name As String, ws As Worksheet
    Dim order_number As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    Set ws = ActiveSheet
    'loop all rows of data
    For i = 1 To ws.Cells(Rows.Count, "A").End(xlUp).Row
        name = Cells(i, 1).Value
        order_number = Cells(i, 2).Value
        If Not dic.exists(name) Then                       'new key?
            dic.Add name, order_number                     'add key and first value
        Else
            dic(name) = dic(name) & "," & order_number     'concatenate new value
        End If
    Next i
    
    DictToRange dic, ws.Range("D1")
    
    'no need to set locally-declared onjects to Nothing...
End Sub

'write keys and values from Dictionary `dic`, starting at `StartCell`
Sub DictToRange(dic As Object, StartCell As Range)
    Dim k, i
    i = 0
    For Each k In dic
        StartCell.Offset(i).Resize(1, 2).Value = Array(k, dic(k))
        i = i + 1
    Next k
End Sub
user_4788840 
Sub sample()
Dim Dic, Dic2, i As Integer, name As String
Dim order_number As Long
Dim tmp_var As Variant
Dim tmp_sp() As String


Set Dic = CreateObject("Scripting.Dictionary") 'Key(キー)とItem(データ)をセットで格納して、リストなどを作成するときに使用。Pythonでいうところのたぶん辞書型
Set Dic2 = CreateObject("Scripting.Dictionary")
On Error Resume Next
    
For i = 1 To 10

    name = Cells(i, 1).Value '荷受人の列の名前を1つずつ取得
    order_number = Cells(i, 2).Value '注文番号を1つずつ取得
    
    Dic.Add name & vbTab & order_number, "" ' Dicに追加していく
Next i


For Each tmp_var In Dic
    tmp_sp = Split(tmp_var, vbTab)
    If Dic2.Exists(tmp_sp(0)) Then
        Dic2.Item(tmp_sp(0)) = Dic2.Item(tmp_sp(0)) & "," & tmp_sp(1)
    Else
        Dic2.Add tmp_sp(0), tmp_sp(1)
    End If
Next

' 出力
myKeys = Dic2.Keys
For i = 0 To Dic2.Count - 1
    Range("C" & i + 1).Value = myKeys(i)
    Range("D" & i + 1).Value = Dic2.Item(myKeys(i))
Next i
'オブジェクトを開放する
Set Dic = Nothing

End Sub

user_99835230
Related