Home > Net >  Adding the first description to a set of unique values in VBA
Adding the first description to a set of unique values in VBA

Time:10-28

I have a spreadsheet that looks a little something like this - Unique Code Example

It uses this code when a button is pressed to provide me the unique values in Column C from the concatenation of column A and B

   Dim Ary As Variant
   Dim r As Long
   
   Ary = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).Value2
   
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         .Item(Ary(r, 1) & " " & Ary(r, 2)) = Empty
      Next r
      Range("C2").Resize(.Count).Value = Application.Transpose(.Keys)
   End With
End Sub

I am looking to modify my spreadsheet so it looks like this instead - Unique Code with Description Example

I have been trying to figure out how to get the first description line in column C to be placed in column E in line with its unique value. Output would look something like this - Unique Code with Unique Description Example

This way even though some of these codes have multiple unique descriptions only the first description is placed in column E. Any suggestions on how to tackle this would be appreciated.

CodePudding user response:

Some small adjustments really:

Sub Test()

Dim arr As Variant, lr As Long, x As Long
   
lr = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("A2:C" & lr).Value
   
With CreateObject("scripting.dictionary")
    For x = LBound(arr) To UBound(arr)
        If .Exists(arr(x, 1) & " " & arr(x, 2)) Then
            'We don't want to overwrite in this case!
        Else
            .Item(arr(x, 1) & " " & arr(x, 2)) = arr(x, 3)
        End If
    Next
    Range("D2").Resize(.Count).Value = Application.Transpose(.Keys)
    Range("E2").Resize(.Count).Value = Application.Transpose(.Items)
End With

End Sub

Note that you are still using implicit sheet references like this, meaning you are always supposed to work from the then active worksheet.

  • Related