Подача нескольких значений в цикле в массив с помощью VBA

Question

Сценарий: Я читаю папки и подпапки каталога, если найденный файл представляет собой «.xls», который он открывает.Затем я запускаю другое условие, которое, если true, попытается передать некоторые значения в массив.

Цель: Я определяю свой массив без измерений, потому что я не знаю, сколько файлов будет загружено в него.Для каждого файла, который удовлетворяет условиям, я пытаюсь получить 3 значения (имя, путь, дата) и добавить в массив.Каждый файл будет добавлен в новую строку массива.

Пример.массива:

Если 3 файла удовлетворяют условию ...

name1    path1    date1
name2    path2    date2
name3    path3    date3

Проблема: , когда я запускаюсь, я получаю индекс вне ошибки ошибкикогда я пытаюсь передать значения в массив.Как я могу это исправить?

Code1: Запускает цикл по папкам

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

Code2: Получает данные:

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