vba help - dictionary Items print duplicate with seperater

[Mallesh23]

Hi Team,

I am trying to print Key's and Items
Column A is (Country) a Key.
if Country comes twice as key but it has different fruits Name.

Then fruit should be combined with Seprator, as shown in Table.

Below is a Table with expected value is Column K.

Sub test()

    Dim dict As New Scripting.Dictionary
  
    Dim arr_Fruit As Variant
    arr_Fruit = Range("A1").CurrentRegion.Value2

dict.RemoveAll
  
    '---------Add Data to Dictionary---------
    With dict
        .CompareMode = TextCompare
      
        For i = LBound(arr_Fruit, 1) To UBound(arr_Fruit, 1)
            If Not .Exists(arr_Fruit(i, 1)) Then
                .Add arr_Fruit(i, 1), Array(arr_Fruit(i, 2), arr_Fruit(i, 3))
            Else
                .Item(arr_Fruit(i, 1)) = .Item(arr_Fruit(i, 1))(0) & "/" & arr_Fruit(i, 2)
              
            End If
        Next i

    Dim c As Range
    For Each c In Range("f2:f4")
  
    If dict.Exists(c.Value) Then
              
        c.Offset(, 1).Value = .Item(c.Value)(0)
  
    End If
  
    Next c

    End With


End Sub

Book12
	A	B	C	D	E	F	G	H	I	J
1	Country	Fruit	Color			Name	Fruit/color		Expected
2	India	Mango	Yellow			India	Mango		Name	Fruit/color
3	Australia	Apple	Green			Australia	Mango		India	Mango
4	England	Banana	Yellow			England			Australia	Mango
5	England	Mango	Blue						England	Banana/Mango
6
Sheet1

Thanks
mg

 

[Fluff]

How about

Sub test()

    Dim dict As New Scripting.Dictionary
  
    Dim arr_Fruit As Variant, Tmp As Variant
    arr_Fruit = Range("A1").CurrentRegion.Value2

dict.RemoveAll
  
    '---------Add Data to Dictionary---------
    With dict
        .CompareMode = TextCompare
      
        For i = LBound(arr_Fruit, 1) To UBound(arr_Fruit, 1)
            If Not .Exists(arr_Fruit(i, 1)) Then
                .Add arr_Fruit(i, 1), Array(arr_Fruit(i, 2), arr_Fruit(i, 3))
            Else
                Tmp = .Item(arr_Fruit(i, 1))
                Tmp(0) = Tmp(0) & "/" & arr_Fruit(i, 2)
                .Item(arr_Fruit(i, 1)) = Tmp
            End If
        Next i

    Dim c As Range
    For Each c In Range("f2:f4")
  
    If dict.Exists(c.Value) Then
              
        c.Offset(, 1).Value = .Item(c.Value)(0)
  
    End If
  
    Next c

    End With


End Sub

 

[Mallesh23]

Hi Fluff,

Wow ! perfect , it worked, got as expected. millions of thanks for help. ?


Thanks
mg

 

[Fluff]

You're welcome & thanks for the feedback.

 

[VBasic2008]

Unique Dictionary With Concatenation

Option Explicit

Sub test()
    
    Const sFirst As String = "A1"
    Const sFirstRow As Long = 2
    Const tFirst As String = "F2"
    Const Delimiter As String = "/"
    
    ' Write values from Source Range to Data Array ('Data').
    Dim Data As Variant
    Data = Range(sFirst).CurrentRegion.Value

    With CreateObject("Scripting.Dictionary")
        ' Write values from Data Array to Unique Dictionary.
        .CompareMode = vbTextCompare
        Dim i As Long
        For i = sFirstRow To UBound(Data, 1)
            If Not .Exists(Data(i, 1)) Then
                .Add Data(i, 1), Data(i, 2)
            Else
                .Item(Data(i, 1)) = .Item(Data(i, 1)) & Delimiter _
                                                      & Data(i, 2)
            End If
        Next i
        ' Write keys and their values from Unique Dictionary to Target Range.
        Dim rng As Range
        Set rng = Range(tFirst).Resize(.Count)
        rng.Value = Application.Transpose(.Keys)
        rng.Offset(, 1).Value = Application.Transpose(.Items)
    End With
    
End Sub

 

[Mallesh23]

Hi VBbasic08,

Perfect ! Thank you much for sharing another way.

Thanks
Mg