VBA values of collection into Excel using VBA

Question

I am trying to copy values into an Excel sheet using VBA code. I have been trying to use a dictionary (as using in my function (8) and utilized in section (3) and (4) ). When I had it set as a dictionary, everything was off by one so I changed the dictonary to be a collection. Now the problem is the line d.Resize(dict.count, 1).Value = Application.Transpose(dict.count) (in section 3 and 4) because it is counting the values and outputting the number of values rather than the name of the value.

I think I need to change it to something more like d.Resize(dict.count, 1).Value = Application.Transpose(VariantArray) but I do not know how to define keys and values since I am not printing a specific range but rather anything present under a specific header.

It's a hard idea to word so if I haven't explained it clearly enough feel free to ask me to explain it better and I'll try to walk you though it more.

Here is my code, any help is greatly appreciated!

Option Explicit

Sub LoopThroughDirectory()

    Const ROW_HEADER As Long = 10

    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim MyFolder As String
    Dim StartSht As Worksheet, ws As Worksheet
    Dim WB As Workbook
    Dim i As Integer
    Dim LastRow As Integer, erow As Integer
    Dim Height As Integer
    Dim RowLast As Long
    Dim f As String
    Dim dict As Object
    Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, d As Range

    Set StartSht = Workbooks("masterfile.xlsm").Sheets("Sheet1")

    'turn screen updating off - makes program faster
    Application.ScreenUpdating = False
    'Application.UpdateLinks = False

    'location of the folder in which the desired TDS files are
    MyFolder = "C:\Users\trembos\Documents\TDS\progress\"

    'find the headers on the sheet
    Set hc1 = HeaderCell(StartSht.Range("B1"), "HOLDER")
    Set hc2 = HeaderCell(StartSht.Range("C1"), "CUTTING TOOL")

    'create an instance of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    'get the folder object
    Set objFolder = objFSO.GetFolder(MyFolder)
    i = 2




    'loop through directory file and print names
'(1)
    For Each objFile In objFolder.Files
        If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then
'(2)
            'print file name to Column 1

            'Open folder and file name, do not update links
            Set WB = Workbooks.Open(fileName:=MyFolder & objFile.Name, UpdateLinks:=0)
            Set ws = WB.ActiveSheet


'(3)
                'find CUTTING TOOL on the source sheet
                Set hc = HeaderCell(ws.Cells(ROW_HEADER, 1), "CUTTING TOOL")
                If Not hc Is Nothing Then

                    Set dict = GetNames(hc.Offset(1, 0))
                    If dict.count > 0 Then
                        Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
                        'add the values to the masterfile, column 3
                        d.Resize(dict.count, 1).Value = Application.Transpose(dict.count)
                    End If
                Else
                    'header not found on source worksheet
                End If

'(4)
                'find HOLDER on the source sheet
                Set hc3 = HeaderCell(ws.Cells(ROW_HEADER, 1), "HOLDER")
                If Not hc3 Is Nothing Then

                    Set dict = GetNames(hc3.Offset(1, 0))
                    If dict.count > 0 Then
                        Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
                        'add the values to the master list, column 2
                        d.Resize(dict.count, 1).Value = Application.Transpose(dict.count)
                    End If
                Else
                    'header not found on source worksheet
                End If

'(5)
            With WB
               'print TDS information
                For Each ws In .Worksheets
                        'print the file name to Column 1
                        StartSht.Cells(i, 1) = objFile.Name
                        'print TDS name from J1 cell to Column 4
                        With ws
                            .Range("J1").Copy StartSht.Cells(i, 4)
                        End With
                        i = GetLastRowInSheet(StartSht) + 1
                'move to next file
                Next ws
'(6)
                'close, do not save any changes to the opened files
                .Close SaveChanges:=False
            End With
        End If
    'move to next file
    Next objFile
    'turn screen updating back on
    Application.ScreenUpdating = True
    ActiveWindow.ScrollRow = 1
'(7)
End Sub

'(8)
'get all unique column values starting at cell c
Function GetNames(ch As Range) As Object
    Dim dict As Object, rng As Range, c As Range, v
    Set dict = New Collection
    For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells
        v = Trim(c.Value)
        If Len(v) > 0 Then
            dict.Add v
        End If
    Next c
    Set GetNames = dict
End Function

'(9)
'find a header on a row: returns Nothing if not found
Function HeaderCell(rng As Range, sHeader As String) As Range
    Dim rv As Range, c As Range
    For Each c In rng.Parent.Range(rng, rng.Parent.Cells(rng.Row, Columns.count).End(xlToLeft)).Cells
        If Trim(c.Value) = sHeader Then
            Set rv = c
            Exit For
        End If
    Next c
    Set HeaderCell = rv
End Function

'(10)
Function GetLastRowInColumn(theWorksheet As Worksheet, col As String)
    With theWorksheet
        GetLastRowInColumn = .Range(col & .Rows.count).End(xlUp).Row
    End With
End Function

'(11)
Function GetLastRowInSheet(theWorksheet As Worksheet)
Dim ret
    With theWorksheet
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            ret = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
        Else
            ret = 1
        End If
    End With
    GetLastRowInSheet = ret
End Function

Answer 1

To get unique items using the Collection object, you need a key. For example:

This will get uniques:

Sub MAIN()
   Dim z As Collection, r As Range
   Set r = Range("A1:A4")

   Set z = GetNames(r)

   msg = z.Count & vbCrLf
   For i = 1 To z.Count
      msg = msg & z.Item(i) & vbCrLf
   Next i
   MsgBox msg
End Sub

'get all unique column values starting at cell c
Function GetNames(ch As Range) As Collection
    Dim dict As Collection, rng As Range, c As Range, v
    Set dict = New Collection
    For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.Count, ch.Column).End(xlUp)).Cells
        v = Trim(c.Value)
        If Len(v) > 0 Then
         On Error Resume Next
            dict.Add v, CStr(v)
         On Error GoTo 0
        End If
    Next c
    Set GetNames = dict
End Function

Answer 2

Since you want all values, not just a unique list, change the Dictionary code to this:

Function GetValues(ch As Range) As Object
    Dim dict As Object, rng As Range, c As Range, v
    Set dict = CreateObject("scripting.dictionary")
    For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.Count, ch.Column).End(xlUp)).Cells
        v = Trim(c.Value)
        If Len(v) > 0 And Not dict.exists(v) Then
            dict.Add c.Address, v
        End If
    Next c
    Set GetValues = dict
End Function

Then use the Items array, not the Keys array:

                Set dict = GetValues(hc3.Offset(1, 0))
                If dict.Count > 0 Then
                    Set d = StartSht.Cells(Rows.Count, hc1.Column).End(xlUp).Offset(1, 0)
                    'add the values to the master list, column 2
                    d.Resize(dict.Count, 1).Value = Application.Transpose(dict.items)
                End If