VBA array, dictionary or collection usage

Question

I'm pretty new to using VBA and have only done basic (maths based) programming before.

About the task: I've been given a folder with tons of files in it that I need to check to see if they're already in the system, this basically requires checking through alphabetically sorted folders, which are then housed within numerically sorted folders, that are finally contained in an overarching folder. the number of alphabetic folders changes for each numeric folder. what I'm wanting to return is the files that are missing, the files that are there, and their folder code eg 6B

About the query: I've investigated arrays, dictionaries, and collections but I haven't come to a conclusion on what is best to use. I'm troubled with what to use to capture the data (file name and folder code), to make the comparison and sorting of it the most simple

Sub comparison()
Dim AR, AQ, AF, AG, AH As Variant

stat_folder = "D:\Public_Digital_Files\Current folder\"
folder_address = "D:\Working_Files\Dan\searchfolder\"

AR = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R")
AQ = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q")
AF = Array("A", "B", "C", "D", "E", "F")
AG = Array("A", "B", "C", "D", "E", "F", "G")
AH = Array("A", "B", "C", "D", "E", "F", "G", "H")


Dim fso As New Scripting.FileSystemObject

'Dim files_current As New Collection
Dim files_current() As Variant
'Dim files_current As New Scripting.Dictionary


For Folder_num = 1 To 7
    If Folder_num = 1 Or Folder_num = 4 Or Folder_num = 6 Then
        For i = 0 To 6
            stat_address = stat_folder & Folder_num & "\" & AG(i) & "\"
            Dir stat_address
            Fname = Dir(stat_address)
            Do Until Fname = ""
                x = x + 1
                ReDim Preserve files_current(2, x)
                files_current(0, x) = Fname
                files_current(1, x) = Folder_num & AG(i)
                'files_current.Add fname, folder_num & AG(i)
                Fname = Dir
            Loop
        Next
    ElseIf Folder_num = 2 Or Folder_num = 5 Then
        For i = 0 To 5
            stat_address = stat_folder & Folder_num & "\" & AF(i) & "\"
            Dir stat_address
            Fname = Dir(stat_address)
            Do Until Fname = ""
                x = x + 1
                ReDim Preserve files_current(2, x)
                files_current(0, x) = Fname
                files_current(1, x) = Folder_num & AF(i)
                'files_current.Add fname, folder_num & AF(i)
                Fname = Dir
            Loop
        Next
    ElseIf Folder_num = 3 Then
        For i = 0 To 16
            stat_address = stat_folder & Folder_num & "\" & AQ(i) & "\"
            Dir stat_address
            Fname = Dir(stat_address)
            Do Until Fname = ""
                x = x + 1
                ReDim Preserve files_current(2, x)
                files_current(0, x) = Fname
                files_current(1, x) = Folder_num & AQ(i)
                'files_current.Add fname, folder_num & AQ(i)
                Fname = Dir
            Loop
        Next
    ElseIf Folder_num = 7 Or Folder_num = 8 Then
        For i = 0 To 17
            stat_address = stat_folder & Folder_num & "\" & AR(i) & "\"
            Dir stat_address
            Fname = Dir(stat_address)
            Do Until Fname = ""
                x = x + 1
                ReDim Preserve files_current(2, x)
                files_current(0, x) = Fname
                files_current(1, x) = Folder_num & AR(i)
                'files_current.Add fname, folder_num & AR(i)
                Fname = Dir
            Loop
        Next
    ElseIf Folder_num = 9 Then
        For i = 0 To 7
            stat_address = stat_folder & Folder_num & "\" & AH(i) & "\"
            Dir stat_address
            Fname = Dir(stat_address)
            Do Until Fname = ""
                x = x + 1
                ReDim Preserve files_current(2, x)
                files_current(0, x) = Fname
                files_current(1, x) = Folder_num & AH(i)
                'files_current.Add fname, folder_num & AH(i)
                Fname = Dir
            Loop
        Next
    End If
Next
'lng = UBound(files_current)
'MsgBox "theres" & lng & "files"

Dim file_search() As Variant
'Dim file_search As New Collection
'Dim file_there As New Scripting.Dictionary
'Dim file_missing As New Collection
Dim file_there() As Variant
Dim file_missing() As Variant

Dir folder_address                                                                                  ' sets the folder as a directory
Fname = Dir(folder_address)                                                                                         ' assigns Fname as the file
Do Until Fname = ""                                                                                 ' loops it until there's no more files
    c = c + 1                                                                                       ' counter, used as an index for the length of files()
    ReDim Preserve file_search(c)
    If InStr(Fname, "_") = 0 Then
        'file_search.Add Left(fname, InStr(fname, ".") - 1)
        file_search(c) = Left(Fname, InStr(Fname, ".") - 1)                                         ' assigns the cth element of files as the new file name
    Else
        'file_search.Add Left(fname, InStr(fname, "_") - 1)
        file_search(c) = Left(Fname, InStr(Fname, "_") - 1)
    End If
    Fname = Dir                                                                                     ' assigns the new Fname
Loop

y = 1
L = 1

For j = 1 To c
'For Each Serch In file_search
    b = 0
    For k = 1 To 392
    'For Each File In files_current.Keys
        'Debug.Print File
        'If InStr(File, Serch) = 1 Then
        'Debug.Print File
        If InStr(files_current(0, k), file_search(j)) = 1 Then
            ReDim Preserve file_there(2, k)
            file_there(0, y) = files_current(0, k)
            'file_there.Add File, files_current(File)
            file_there(1, y) = files_current(1, k)
            b = 1
            y = y + 1
        End If
    Next
    If b = 0 Then
        ReDim Preserve file_missing(L)
        'file_missing.Add Serch
        file_missing(L) = file_search(j)
        L = L + 1
    End If
Next

'a = 1
'b = 1

'For Each missing In file_missing
'Range("A" & a) = missing
'a = a + 1
'Next

'For Each there In file_there
'Range("B" & b) = there
'Range("C" & c) = file_there(there)
'b = b + 1
'Next

Range("A2:A" & L & 1) = Application.Transpose(file_missing)
Range("B2:C" & y & 1) = Application.Transpose(file_there)

MsgBox "stop"




End Sub

Answer 1

FIXED - this way now works too it uses classes, dictionaries, and arrays as it was easier to compare the when the current files were define as an array.

clsinfo is just a random class i used so that I could pass the drawing number, revision, file type, and folder code all in to the dictionary.

Sub compare()

Const stat_folder = "D:\Public_Digital_Files\Current folder\"
Const folder_address = "D:\Working_Files\Dan\searchfolder\"
len_fold = Len(folder_address)

Dim x As Long, i As Long, folder_num As Long, sub_num As Long
Dim stat_address As String, fname As String
Dim files_current1() As String, files_current2() As String

x = 1

For folder_num = 1 To 9

    Select Case folder_num
        Case 1, 4, 6:   sub_num = 7
        Case 2, 5:      sub_num = 6
        Case 3:         sub_num = 17
        Case 7, 8:      sub_num = 18
        Case 9:         sub_num = 8
    End Select


    For i = 1 To sub_num
        stat_address = stat_folder & "\" & folder_num & "\" & Chr(64 + i) & "\"
        fname = Dir(stat_address)
        Do While fname <> ""
            ReDim Preserve files_current1(1 To x), files_current2(1 To x)
            files_current2(x) = folder_num & Chr(64 + i)
            files_current1(x) = fname
            fname = Dir()
            x = x + 1
        Loop
    Next
Next


Set fso = CreateObject("SCripting.FileSystemObject")


Dim files_there As New Scripting.Dictionary
Dim files_missing As New Scripting.Dictionary
Dim seerch As clsinfo


fname = Dir(folder_address)

Do While fname <> ""
    Set seerch = New clsinfo
    seerch.ftype = Right(fname, 3)
    underscore_pos = InStr(fname, "_")
    dot_pos = InStr(fname, ".")
    If underscore_pos <> 0 Then
        rev_len = dot_pos - underscore_pos
        seerch.rev = Mid(fname, underscore_pos + 1, rev_len)
        seerch.dwg_num = Left(fname, underscore_pos - 1)
        GoTo H
    End If
    seerch.dwg_num = Left(fname, dot_pos - 1)
    seerch.rev = Empty
    DoEvents
H:
    For j = 1 To x - 1
        If InStr(1, files_current1(j), seerch.dwg_num) = 1 Then
            seerch.fcode = files_current2(j)
            seerch.Ctype = Right(files_current1(j), 3)
            seerch.Crev = Mid(files_current1(j), underscore_pos + 1, rev_len)
            files_there.Add fname, seerch
            GoTo Z
        End If
    Next
    files_missing.Add fname, seerch
    DoEvents
Z:
    fname = Dir()
Loop


Range("A1") = "Missing Drawing numbers"
Range("B1") = "missing revision number"
Range("C1") = "Missing filetype"
Range("D1") = "drawings that already exist"
Range("E1") = "revision of fresh drawing"
Range("F1") = "Revision of CURRENT drawing"
Range("G1") = "file type of fresh drawing"
Range("H1") = "file type of CURRENT drawing"
Range("I1") = "Current Folder"


For a = 2 To files_missing.Count - 1
    Range("A" & a) = files_missing.Items(a).dwg_num
    Range("B" & a) = files_missing.Items(a).rev
    Range("C" & a) = files_missing.Items(a).ftype
Next

For b = 2 To files_there.Count - 1
    Range("D" & b) = files_there.Items(b).dwg_num
    Range("E" & b) = files_there.Items(b).rev
    Range("F" & b) = files_there.Items(b).ftype
    Range("G" & b) = files_there.Items(b).Crev
    Range("H" & b) = files_there.Items(b).Ctype

Next

MsgBox "stop"
End Sub

Answer 2

This is an incomplete answer, and hasn't even been tested, using nested Dictionarys and the FileSystemObject. But it duplicates the logic of this answer.

---

You need to add a reference to the Microsoft Scripting Runtime (Tools -> References...). Alternatively, you can replace New statements with CreateObject:

Dim fso As New Scripting.FileSystemObject

becomes

Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")

---

Function GetLetters(folderNumber As Integer) As Variant
    Dim maxNumber As Integer, i As Integer
    Select Case folderNumber
        Case 1, 4, 6: maxNumber = 6
        Case 2, 5:    maxNumber = 5
        Case 3:       maxNumber = 16
        Case 7, 8:    maxNumber = 17
        Case 9:       maxNumber = 7
    End Select
    Dim ret() As String
    ReDim ret(maxNumber)
    For i = 0 To maxNumber
        ret(i) = Chr(65 + i)
    Next
    GetLetters = ret
End Function

Sub Compare()
    Const sourceRoot = "D:\Public_Digital_Files\Current folder\"
    Const searchRoot = "D:\Working_Files\Dan\searchfolder\"

    Dim statFiles As New Scripting.Dictionary
    Dim missingFiles As New Scripting.Dictionary

    Dim fso As New Scripting.FileSystemObject
    Dim f As Scripting.file
    Dim folderNumber As Integer, folderLetter As String
    For folderNumber = 1 To 9
        For Each folderLetter In GetLetters(folderNumber)
            Dim folderPath As String
            folderPath = Join(Array(sourceRoot, folderNumber, folderLetter), "\")
            For Each f In fso.GetFolder(folderPath).files
                If Not statFiles.Exists(fle.name) Then statFiles(fle.name) = New Scripting.Dictionary
                statFiles(fle.name)(folderNumber & folderLetter) = 1 'dummy value
            Next
        Next
    Next

    For Each f In fso.GetFolder(searchRoot).files
        Dim baseName As String, revision As String
        baseName = fso.GetBaseName(f) 'returns the filename without the extension and without the folder
        revision = ""

        Dim underscorePosition As Integer
        underscorePosition = InStr(baseName, "_")
        If underscorePosition <> 0 Then
            revision = Mid(baseName, underscorePosition + 1)
            baseName = Left(baseName, underscorePosition - 1)
        End If

        Dim key As String
        key = baseName & "." & fso.GetExtensionName(f) 'gets the extension without a period
        If statFiles.Exists(key) Then
            'do something here?
        Else
            missingFiles(key) = 1 'dummy value
        End If
    Next

    'At this point, you can iterate through the dictionaries

    'This loop will print each filename, together with the foldercodes under which it can be found
    Dim filename As Variant, folderCode As Variant
    For Each filename In statFiles.keys
        For Each folderCode In statFiles(key).keys
            Debug.Print folderCode, key1
        Next
    Next

    'This loop will print the missing filenames
    For Each filename In missingFiles.keys
        Debug.Print filename
    Next
End Sub

Answer 3

What I ended up doing was using arrays as although they were a bit cumbersome (having to redim so many arrays) they were a fairly straight forward way of doing it. I also did it using classes and dictionaries, I can definitely see their usefulness now but it ended up getting more complex than needed because of the files having both multiple revisions and filetypes that made the comparison. here's the code for the array method, and I'll also post the one using classes&dictionaries

Sub compare()

Const stat_folder = "D:\Public_Digital_Files\Current folder\"
Const folder_address = "D:\Working_Files\Dan\searchfolder\"
len_fold = Len(folder_address)

Dim x As Long, i As Long, folder_num As Long, sub_num As Long
Dim stat_address As String, fname As String
Dim files_current1() As Variant
Dim files_current2() As Variant
Dim current As clsinfo

x = 0

For folder_num = 1 To 9

    Select Case folder_num
        Case 1, 4, 6:   sub_num = 7
        Case 2, 5:      sub_num = 6
        Case 3:         sub_num = 17
        Case 7, 8:      sub_num = 18
        Case 9:         sub_num = 8
    End Select


    For i = 1 To sub_num
        stat_address = stat_folder & folder_num & "\" & Chr(64 + i) & "\"
        fname = Dir(stat_address)
        Do While fname <> ""
            x = x + 1
            ReDim Preserve files_current1(1 To x)
            ReDim Preserve files_current2(1 To x)
            files_current1(x) = fname
            files_current2(x) = folder_num & Chr(64 + i)
            fname = Dir()
        Loop
    Next
Next

Set fso = CreateObject("SCripting.FileSystemObject")

'Dim fso As New Scripting.FileSystemObject

Dim files_therename() As Variant, files_thererev() As Variant, files_thereCrev() As Variant
Dim files_theretype() As Variant, files_thereCtype() As Variant, files_therecode() As Variant
Dim files_missingname() As Variant, files_missingrev() As Variant, files_missingtype() As Variant

Set search_folder = fso.GetFolder(folder_address).files
Dir folder_address

j = 1
k = 1
l = 1

For Each file In search_folder
    file = Mid(file, len_fold + 1)
    file_type = Right(file, 3)
    If InStr(file, "_") = 0 Then
        file_name = Left(file, InStr(file, ".") - 1)
        file_rev = Empty
    Else
        midd = InStr(file, "_")
        file_name = Left(file, midd - 1)
        rev_len = InStr(file, ".") - midd
        file_rev = Mid(file, midd + 1, rev_len)
    End If
    For j = 1 To x
        If InStr(1, files_current1(j), file_name) = 1 Then
            ReDim Preserve files_therename(k)
            ReDim Preserve files_thererev(k)
            ReDim Preserve files_thereCrev(k)
            ReDim Preserve files_theretype(k)
            ReDim Preserve files_thereCtype(k)
            ReDim Preserve files_therecode(k)

            files_therename(k) = file_name
            files_thererev(k) = file_rev
            files_thereCrev(k) = Mid(files_current1(j), midd + 1, rev_len)
            files_theretype(k) = file_type
            files_thereCtype(k) = Right(files_current1(j), 3)
            files_therecode(k) = files_current2(j)
            k = k + 1
            GoTo H
        End If
    Next

    ReDim Preserve files_missingname(l)
    ReDim Preserve files_missingrev(l)
    ReDim Preserve files_missingtype(l)
    files_missingname(l) = file_name
    files_missingrev(l) = file_rev
    files_missingtype(l) = file_type
    l = l + 1

H:
Next file
End Sub

Answer 4

Not an answer, but that whole first part of your procedure can be reduced to this:

Const stat_folder As String = "D:\Public_Digital_Files\Current folder\"
Const folder_address As String = "D:\Working_Files\Dan\searchfolder\"

Dim x As Long, i As Long, folder_num As Long, sub_num As Long
Dim stat_address As String, fname

Dim files_current() As Variant

ReDim files_current(1 To 2, 1 To 1)

x = 0
For folder_num = 1 To 9

    Select Case folder_num
        Case 1, 4, 6: sub_num = 7
        Case 2, 5: sub_num = 6
        Case 3: sub_num = 17
        Case 7, 8: sub_num = 18
        Case 9: sub_num = 8
    End Select

    For i = 1 To sub_num

        stat_address = stat_folder & folder_num & "\" & Chr(64 + i) & "\"
        'Debug.Print stat_address
        fname = Dir(stat_address)
        Do While fname <> ""
            x = x + 1
            If x > 1 Then ReDim Preserve files_current(1 To 2, 1 To x)
            files_current(1, x) = fname
            files_current(2, x) = folder_num & Chr(64 + i)
            fname = Dir()
        Loop

    Next i

Next folder_num