我很擅长使用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
答案 0 :(得分：2)
不是答案，但整个过程的第一部分可以简化为：
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
答案 1 :(得分：0)
我最终做的是使用数组，虽然它们有点麻烦（必须重新编译这么多数组），但它们是一种相当直接的方式。我也使用类和字典做了它，我现在肯定可以看到它们的用处，但它最终变得比需要的更复杂，因为文件有多个修订版和文件类型进行比较。这是数组方法的代码，我也将使用类和字典发布一个
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
答案 2 :(得分：0)
FIXED - 这种方式现在也可以使用类，字典和数组，因为它更容易比较当前文件被定义为数组的时间。
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
答案 3 :(得分：0)
这是一个不完整的答案，甚至没有使用嵌套Dictionary和FileSystemObject进行测试。但它重复了this回答的逻辑。
您需要添加对 Microsoft Scripting Runtime 的引用（工具 - ＆gt; 引用... ）。或者，您可以将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