Question

方案：：我正在阅读目录的文件夹和子文件夹，如果找到的文件是“ .xls”，则它将打开。然后，我运行另一个条件，如果为true，将尝试将一些值传递给数组。

目标：我要定义没有维度的数组，因为我不知道有多少文件可以输入。对于每个满足条件的文件，我试图获取3个值（名称，路径，日期）并添加到数组中。每个文件都将添加到数组的新行。

例如数组：

如果3个文件满足条件...

name1    path1    date1
name2    path2    date2
name3    path3    date3

问题：：运行时，尝试将值传递给数组时出现下标超出范围错误。我该如何解决？

代码1：这将开始循环浏览文件夹

Public Sub getInputFileInfo()
    Dim FileSystem As Object
    Dim HostFolder As String

    ' User selects where to search for files:
    HostFolder = GetFolder()

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)

End Sub

代码2：这将获取数据：

Public Sub DoFolder(Folder)

    Dim strFilename As String, filePath As String
    Dim dateC As Date
    Dim oFS As Object
    Dim outputarray() As Variant
    Dim ii As Long, lRow As Long, lCol As Long, lRow2 As Long
    Dim w2, w As Workbook
    Set w = ThisWorkbook

    ii = 1

    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next SubFolder
    Dim File
    For Each File In Folder.Files
        Set oFS = CreateObject("Scripting.FileSystemObject")
        'Set w2 = File

        filePath = File.Path
        strFilename = File.Name
        dateC = File.dateCreated
        If InStr(LCase(File.Path), LCase("xls")) <> 0 Then
            Set w2 = Workbooks.Open(filePath)
            For lRow2 = 1 To w2.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
                If w2.Sheets(1).Range("A" & lRow2).Value = "Test Name" Then
                    outputarray(0, ii) = strFilename ' THE ERROR STARTS HERE
                    outputarray(1, ii) = filePath
                    outputarray(2, ii) = dateC
                    ii = ii + 1
                End If
            Next lRow2
            w2.Close False
        End If
        Set oFS = Nothing
    Next File

    For lRow = 1 To UBound(outputarray, 1)
        For lCol = 1 To UBound(outputarray, 2)
            w.Sheets("ControlSheet").Cells(lRow, lCol).Value = outputarray(lRow, lCol).Value
        Next lCol
    Next lRow

End Sub

Answer 1

我将使用字典和“类”，如以下示例所示。 fInfo类看起来像这样

Option Explicit

Public fileName As String
Public filepath As String
Public fileDateCreated As Date

那么您可以像这样测试它

Sub AnExample()

Dim dict As New Scripting.Dictionary
Dim fInfo As fileInfo

Dim filepath As String
Dim strFilename As String
Dim dateC As Date
Dim i As Long

    For i = 1 To 2
        filepath = "Path\" & i
        strFilename = "Name" & i
        dateC = Now + 1

        Set fInfo = New fileInfo
        With fInfo
            .filepath = filepath
            .fileName = strFilename
            .fileDateCreated = dateC
        End With
        dict.Add i, fInfo
    Next i

    For i = 1 To dict.Count
        With dict.Item(i)
            Debug.Print .filepath, .fileName, .fileDateCreated
        End With
    Next i

End Sub

在您的代码中也许是这样

    For lRow2 = 1 To w2.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
        If w2.Sheets(1).Range("A" & lRow2).Value = "Test Name" Then
            Set fInfo = New fileInfo
            With fInfo
                .filepath = filepath
                .fileName = strFilename
                .fileDateCreated = dateC
            End With
            dict.Add ii, fInfo
'            outputarray(0, ii) = strFilename    ' THE ERROR STARTS HERE
'            outputarray(1, ii) = filepath
'            outputarray(2, ii) = dateC
'            ii = ii + 1
        End If
    Next lRow2

Answer 2

尝试以下步骤：

1）临时将数组的大小调整为最大文件数

2）跟踪找到的文件

3）最终将数组的大小调整为找到的文件的实际数量

如下（我仅显示相关代码段）：

ii = -1 '<<< initialize the counter fo found files to -1: it's more convenient for its subsequent updating and usage
ReDim outputarray(0 To 2, 0 To Folder.Files.Count) As Variant ' <<< temporarily size the array to the maximum number of files

For Each File In Folder.Files
    Set oFS = CreateObject("Scripting.FileSystemObject")
    'Set w2 = File

    filePath = File.Path
    strFilename = File.Name
    dateC = File.dateCreated
    If InStr(LCase(File.Path), LCase("xls")) <> 0 Then
        Set w2 = Workbooks.Open(filePath)
        For lRow2 = 1 To w2.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
            If w2.Sheets(1).Range("A" & lRow2).Value = "Test Name" Then
                ii = ii + 1 '<<< update the number of found files
                outputarray(0, ii) = strFilename
                outputarray(1, ii) = filePath
                outputarray(2, ii) = dateC
            End If
        Next lRow2
        w2.Close False
    End If
    Set oFS = Nothing
Next File

ReDim Preserve outputarray(0 To 2, 0 To ii) As Variant '<<< finally resize array to actual number of found files

编辑

顺便说一句，您可以避免双重嵌套的书写循环，并使用单发语句：

w.Sheets("ControlSheet").Range("A1").Resize(UBound(outputarray, 1) + 1, UBound(outputarray, 2) + 1).Value = outputarray

使用VBA在循环中将多个值馈送到数组

2 个答案: