I'd like to loop from D6 to end of row 6 and add the values encountered to my dictionary "dict" as a key. I get a 91 error. How can I fix it ?

Function list()

Dim i As Long
Dim currCell As Range
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")


With tg
    For Each currCell In .Range("D6", .Cells(.Columns.Count, 2).End(xlToLeft))
        If Not dict.Exists(currCell.Value) And Not IsEmpty(currCell) Then
            dict.Add currCell.Value, ""
        End If
    Next currCell
End With

Set list = dict

End Function

CodePudding user response：

Here's how you would write the function to gather row 6 values in a dictionary starting at column D:

Function list() As Object
    
    Dim ws As Worksheet, wsTG As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.CodeName = "tg" Then
            Set wsTG = ws
            Exit For
        End If
    Next ws
    If wsTG Is Nothing Then Exit Function 'No sheet with codename "tg" found
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim rData As Range: Set rData = wsTG.Range("D6", wsTG.Cells(6, wsTG.Columns.Count).End(xlToLeft))
    If rData.Column < 4 Then Exit Function  'No data found
    
    Dim vCell As Variant
    For Each vCell In rData.Value
        If Not dict.Exists(vCell) Then dict.Add vCell, ""
    Next vCell
    
    Set list = dict
    
End Function

This is a little sub to test the function and show the output:

Sub tgr()
    
    Dim myDict As Object:   Set myDict = list()
    
    MsgBox Join(myDict.Keys, ",")
    
End Sub

CodePudding user response：

Return the Unique Values From a Range in a Dictionary

Option Explicit

Sub DictRangeTEST()

    ' Reference the range. 'tg' is the code name of a worksheet
    ' in the workbook containing this code.
    Dim rg As Range
    Set rg = tg.Range("D6", tg.Cells(6, tg.Columns.Count).End(xlToLeft))
    Debug.Print rg.Address ' see the address in the Immediate window ('Ctrl G')

    ' Write the unique values from the range to a dictionary.
    Dim dict As Object: Set dict = DictRange(rg)
    
    ' Check if there are no values in the dictionary.
    If dict.Count = 0 Then
        MsgBox "No valid values found.", vbCritical
        Exit Sub
    End If
    
    ' Continue, e.g. print the keys
    Dim Key As Variant
    For Each Key In dict.Keys
        Debug.Print Key
    Next Key

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the unique values from a range ('rg')
'               in the keys of a dictionary.
' Remarks:      Error values and blanks are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictRange(ByVal rg As Range) As Object
    Const ProcName As String = "DictRange"
    On Error GoTo ClearError
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' make it case-insensitive i.e. 'A = a'
    
    Dim cCell As Range
    Dim Key As Variant
    
    For Each cCell In rg.Cells
        Key = cCell.Value
        If Not IsError(Key) Then ' exclude error values
            If Len(Key) > 0 Then ' exclude blanks
                dict(Key) = Empty
            End If
        End If
    Next cCell
    
    Set DictRange = dict

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function