VBA 数组、字典或集合的使用答案

【问题标题】：VBA array, dictionary or collection usageVBA 数组、字典或集合的使用
【发布时间】：2017-05-05 02:09:54
【问题描述】：

我对使用 VBA 很陌生，之前只做过基本的（基于数学的）编程。

关于任务：我得到了一个包含大量文件的文件夹，我需要检查它们是否已经在系统中，这基本上需要检查按字母排序的文件夹，然后将这些文件夹放在按数字排序的文件夹中，最后包含在一个总体文件夹中。每个数字文件夹的字母文件夹数量会发生变化。我要返回的是丢失的文件、存在的文件以及它们的文件夹代码，例如 6B

关于查询：我研究了数组、字典和集合，但我还没有得出关于什么是最好用的结论。我很烦恼用什么来抓取数据（文件名和文件夹代码），让比较和排序变得最简单

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

【问题讨论】：

问题太宽泛了。
tldr版本就是纠结用什么来抓数据（文件名和文件夹代码），比较和排序最简单
将信息写入工作表，然后您可以根据需要进行排序/过滤。你的数据集的实际大小是多少？您需要检查多少个文件/文件夹？不过那里的代码太多了。
@dd_tall：好吧，我几乎用字典来处理所有事情，即使一个ciollection 或一个数组就足够了。
我会为此使用一个字典。遍历源目录并为您找到的所有内容添加键。然后迭代您找到的比较目录和 remove 键。完成后字典中剩下的所有内容都是您的结果集。

标签： arrays vba sorting dictionary collections

【解决方案1】：

已修复 - 这种方式现在也可以使用，它使用类、字典和数组，因为更容易比较当前文件何时定义为数组。

clsinfo 只是我使用的一个随机类，因此我可以将图纸编号、修订、文件类型和文件夹代码全部传递到字典中。

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

【讨论】：

这种方式需要 4.5 秒来运行（并打印）文件，而在我的其他答案中仅使用数组需要 61 秒。

【解决方案2】：

这是一个不完整的答案，甚至尚未使用嵌套的Dictionarys 和FileSystemObject 进行测试。但它重复了this答案的逻辑。

您需要添加对 Microsoft Scripting Runtime 的引用（Tools -> References...）。或者，您可以将 New 语句替换为 CreateObject：

Dim fso As New Scripting.FileSystemObject

变成

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

【讨论】：

【解决方案3】：

我最终做的是使用数组，虽然它们有点麻烦（必须重新调整这么多数组），但它们是一种相当直接的方式。我也使用类和字典来完成它，我现在肯定可以看到它们的用处，但它最终变得比需要的更复杂，因为文件具有多个修订版和进行比较的文件类型。这是数组方法的代码，我也将使用类和字典发布一个

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

【讨论】：

在第二部分中，您可以避免重复的 ReDim 操作，方法是在开始时将大小调整为最大可能大小 (X)，然后在最后减少到“使用”大小（k 和 l）
您的第二个循环似乎没有在任何嵌套文件夹中查找 - Folder 对象的 Files 集合仅包含该文件夹中直接文件的 File 对象，而不是子文件夹中的文件.
您严重低估了 FileSystemObject 的使用，您可以使用它来遍历文件夹中的子文件夹、文件，并使用 Folder 和 File 对象返回有关文件夹和文件的信息（而不是将文件/文件夹路径解析为字符串）。

【解决方案4】：

不是一个答案，但您的程序的整个第一部分可以简化为：

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

【讨论】：

谢谢！我以前没有遇到过 Chr。