我一直在制作一个vba脚本来扫描目录的内容并使用该扫描结果更新表格。结果是文件是Unchanged，New或Missing，它将更新到表的File Status列。如果它是新的，那么它会将文件名放入表格的Filename列中。
我的代码相当接近，但我遇到了一些通过两个数组的逻辑问题。我已经耗尽了我的能力而不会在代码中造成更多问题而进行查看，进一步的更改会导致代码中的回归。
任何人都可以查看代码，看看我是否在正确的道路上，或者我是否犯了一个简单的错误？它错误地标记为某些文件缺失或新标记不应该出现，但我相信它会在出现其他任何错误之前正确标记未更改的文件。
Sub FolderContents()
Dim objFSO, objFolder, objFile As Object
Dim g, h, i, j, k, l As Integer
Dim myTable As ListObject
Dim myArray As Variant
Dim FileArray(), FileStatusArray() As String
Dim wsName, tbName, fnName, fsName, Path As String
Dim colNumFile, colNumStatus As Long
Dim newRow As ListRow
h = 1
j = 1
l = 1
' Change only these values if name of table or worksheets change
wsName = "Signage List" 'Worksheet name that contains the signage table
tbName = "Signage" 'Table name for the signage file data
fnName = "Filename" 'Column name that contains the file names
fsName = "File Status" 'Column name that contains the file statuses
' ! DO NOT EDIT ANYTHING BELOW THIS LINE !
Application.FileDialog(msoFileDialogFolderPicker).ButtonName = "Select Folder"
Set objFSO = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select destination folder"
If .Show = -1 And .SelectedItems.Count = 1 Then
Path = .SelectedItems(1)
Else: Exit Sub
End If
End With
Set objFolder = objFSO.GetFolder(Path)
Set myTable = Worksheets(wsName).ListObjects(tbName)
colNumFile = myTable.ListColumns(fnName).Index
colNumStatus = myTable.ListColumns(fsName).Index
If Not myTable.ListColumns(colNumFile).DataBodyRange Is Nothing Then
myArray = myTable.ListColumns(colNumFile).DataBodyRange
End If
If Not IsEmpty(myArray) Then
For Each objFile In objFolder.Files
If objFile.Type = "PNG image" Then
For i = LBound(myArray) To UBound(myArray)
ReDim Preserve FileArray(1 To j)
ReDim Preserve FileStatusArray(1 To j)
If myArray(i, 1) = objFile.Name Then
FileArray(j) = objFile.Name
Cells(i + 1, colNumStatus) = "Unchanged"
FileStatusArray(j) = "Unchanged"
GoTo NextFile
Else
FileArray(j) = objFile.Name
FileStatusArray(j) = "New"
End If
Next i
NextFile:
j = j + 1
End If
Next objFile
For k = LBound(FileArray) To UBound(FileArray)
For l = LBound(myArray) To UBound(myArray)
If Not myArray(l, 1) = FileArray(k) Then
Cells(l + 1, colNumStatus) = "Missing"
GoTo AnotherFile
Else
Cells(l + 1, colNumStatus) = "Unchanged"
End If
Next l
AnotherFile:
If FileStatusArray(k) = "New" Then
Set newRow = myTable.ListRows.Add(AlwaysInsert:=True)
Set myTable = Worksheets(wsName).ListObjects(tbName)
newRow.Range.Cells(1, colNumStatus) = "New"
newRow.Range.Cells(1, colNumFile) = FileArray(k)
End If
Next k
Else
For Each objFile In objFolder.Files
If objFile.Type = "PNG image" Then
ReDim Preserve FileArray(1 To h)
ReDim Preserve FileStatusArray(1 To h)
FileArray(h) = objFile.Name
FileStatusArray(h) = "New"
h = h + 1
End If
Next objFile
For g = LBound(FileArray) To UBound(FileArray)
Set newRow = myTable.ListRows.Add(AlwaysInsert:=True)
Set myTable = Worksheets(wsName).ListObjects(tbName)
newRow.Range.Cells(1, colNumStatus) = "New"
newRow.Range.Cells(1, colNumFile) = FileArray(g)
Next g
End If
End Sub
谢谢！
答案 0 :(得分：0)
我没有多次遍历范围或数组，而是将值添加到字典中。我也尝试将大型子程序分解为更小的任务。
Sub FolderContents()
Application.ScreenUpdating = False
' Change only these values if name of table or worksheets change
Const wsName = "Signage List" 'Worksheet name that contains the signage table
Const tbName = "Signage" 'Table name for the signage file data
Const fnName = "Filename" 'Column name that contains the file names
Const fsName = "File Status" 'Column name that contains the file statuses
Dim dImageFiles
Dim tblSignage As ListObject
Dim newRow As Range
Dim k As String
Dim x As Long, colNumFile As Long, colNumStatus As Long
Set dImageFiles = getSignageImageFilesDictionary
If dImageFiles.Count = 0 Then
' Do Something if no folder was selected
End If
Set tblSignage = Worksheets(wsName).ListObjects(tbName)
With tblSignage
colNumFile = .ListColumns(fnName).Index
colNumStatus = .ListColumns(fsName).Index
With .DataBodyRange
For x = 1 To .Rows.Count
k = .Cells(x, colNumFile).Text
If dImageFiles.Exists(k) Then
.Cells(x, colNumStatus) = "Unchanged"
dImageFiles.Remove k
Else
.Cells(x, colNumStatus) = "Missing"
End If
Next x
End With
End With
For x = 0 To dImageFiles.Count - 1
Set newRow = tblSignage.ListRows.Add(AlwaysInsert:=True).Range
newRow.Cells(1, colNumFile) = dImageFiles.keys(x)
newRow.Cells(1, colNumStatus) = "New"
Next x
Application.ScreenUpdating = True
End Sub
Function getSignageImageFilesDictionary()
Dim folderPath As String
Dim dict, fso, f
Set dict = CreateObject("Scripting.Dictionary")
Set fso = CreateObject("Scripting.FileSystemObject")
folderPath = getFolderPath
If Len(folderPath) Then
For Each f In fso.GetFolder(folderPath).Files
If fso.GetExtensionName(f.Path) = "png" Then
If Not dict.Exists(f.Name) Then dict.Add f.Name, f.Path
End If
Next
End If
Set getSignageImageFilesDictionary = dict
Set fso = Nothing
End Function
Function getFolderPath() As String
Application.FileDialog(msoFileDialogFolderPicker).ButtonName = "Select Folder"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select destination folder"
If .Show = -1 And .SelectedItems.Count = 1 Then
getFolderPath = .SelectedItems(1)
Else: Exit Function
End If
End With
End Function
我没有看到任何使用数组的理由。如果你正在处理大量的数据，我会通过转换表格的数据格式来创建一个多维数组。它需要转置，因为只能调整数组的最后一个维度。接下来可以是数组的值并向其添加新行。最后，我们将数组转换为existiong数据集范围。
Sub FolderContents()
' Change only these values if name of table or worksheets change
Const wsName = "Signage List" 'Worksheet name that contains the signage table
Const tbName = "Signage" 'Table name for the signage file data
Const fnName = "Filename" 'Column name that contains the file names
Const fsName = "File Status" 'Column name that contains the file statuses
Dim dImageFiles
Dim tblSignage As ListObject
Dim k As String
Dim x As Long, count As Long, colCount As Long, colNumFile As Long, colNumStatus As Long
Dim arData, v
Set dImageFiles = getSignageImageFilesDictionary
If dImageFiles.count = 0 Then
' Do Something if no folder was selected
End If
Set tblSignage = Worksheets(wsName).ListObjects(tbName)
With tblSignage
colNumFile = .ListColumns(fnName).Index
colNumStatus = .ListColumns(fsName).Index
colCount = .DataBodyRange.Columns.count
arData = WorksheetFunction.Transpose(.DataBodyRange)
For x = 1 To UBound(arData, 2)
k = arData(colNumFile, x)
If dImageFiles.Exists(k) Then
arData(colNumStatus, x) = "Unchanged"
dImageFiles.Remove k
Else
arData(colNumStatus, x) = "Missing"
End If
Next x
For Each v In dImageFiles.keys()
count = UBound(arData, 2) + 1
ReDim Preserve arData(1 To colCount, 1 To count)
arData(colNumFile, count) = v
arData(colNumStatus, count) = "New"
Next v
.DataBodyRange.Cells(1, 1).Resize(UBound(arData, 2), colCount) = WorksheetFunction.Transpose(arData)
End With
End Sub