如何在 VBA 中在同一值旁边输出相同类型的值？

发布于 2025-01-20 05:04:12 字数 8 浏览 2 评论 0原文

continue

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

Same names in column A are made into one and output to column C.
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

分享到QQ

分享到微博

如果你对这篇内容有疑问，欢迎到本站社区发帖提问参与讨论，获取更多帮助，或者扫码二维码加入 Web 技术交流群。

发布评论

需要登录才能够评论，你可以免费注册一个本站的账号。

静待花开 2025-01-27 05:04:12

您只能在字典上调用 Add - 您需要检查字典是否已经将 name 作为键，并且 Add新密钥或更新现有值。

试试这个：

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

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

回复收藏 0 原文

芸娘子的小脾气 2025-01-27 05:04:12

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

结束子

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

回复收藏 0 原文

~没有更多了~