Office: (Office 2013) Problem bei einer Array Erstellung

Hallo zusammen,

ich habe mal eine Frage zu Arrays.
Mein Ziel ist es ein eindimensionales Array, also eine Liste, mit verschiedenen Dateipfaden zu befüllen, damit dieses Array durch ein anderes Makro weiterverarbeitet werden kann.

Was das Makro macht bzw machen soll:

1. Bestimmen der xlsb Dateien in einem bestimmten Ordner mit Unterordnern
2. Diesen ermittelten Count dem Array mit ReDim zuweisen, damit die Obergrenze festgelegt wird.
3. Befüllen der des Arrays mit Dateipfaden.

Mein Problem ist das der Array einfach nicht funktionieren will und immer die Fehlermeldung „Index außerhalb des gültigen Bereiches“ erscheint (die Problemstelle habe ich mal Fett markiert).

Habt Ihr eine Idee was da schief läuft?

SG
Tauchmann

Code:

Public strFilePathArray() As String
 
Public Function RelevantFilesPathesOrCount()  
    Dim strFolderPath As String
    Dim lngFileCount As Long
    Dim lngDummy As Long
    Dim i As Long
 
    strFolderPath = "C:\Test"
   
    lngFileCount = 0
    lngFileCount = GoThroughSubFolder(strFolderPath, lngFileCount, "Count")
    lngDummy = GoThroughSubFolder(strFolderPath, lngFileCount, "Array")
   
    lngDummy = UBound(strFilePathArray)
    Erase strFilePathArray
End Function
 
Public Function GoThroughSubFolder(ByVal strFolderPath As String, lngFileCount As Long, strWhat As String) As Long
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objSubFolder As Object
    Dim objFile As Object
    Dim i As Long
   
    Erase strFilePathArray
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.getfolder(strFolderPath)
   
    Select Case strWhat
        Case Is = "Array"
            ReDim strFilePathArray(lngFileCount)
    End Select
   
    For Each objSubFolder In objFolder.subfolders
'Alle Dateien durchlaufen
        For Each objFile In objSubFolder.Files
            If LCase(objFSO.getextensionname(objFile)) = "xlsb" Then
                Select Case strWhat
                    Case Is = "Count"
                        lngFileCount = lngFileCount + 1
                    Case Is = "Array"
                        For i = 1 To lngFileCount
                            [B]strFilePathArray(i) = objFile.Path[/B]
                        Next i
                End Select
            End If
        Next objFile
       
'Alle Unterverzeichnisse durchlaufen (rekursiv)
    Call GoThroughSubFolder(objSubFolder.Path, lngFileCount, strWhat)
    Next objSubFolder
   
    GoThroughSubFolder = lngFileCount
    Erase strFilePathArray
    Set objFSO = Nothing
    Set objFile = Nothing
    Set objFolder = Nothing
    Set objSubFolder = Nothing
End Function

 

Hallo,

ich glaube ich habe vielleicht das Problem gefunden.
Muss noch rumprobieren.

SG
Tauchmann

 

Ohhhhh man , da habe ich mir selbst ein ziemlich großes OsterEI gelegt.
Naja, man sollte nicht spät Abends programieren :)
Habe das Problem gefunden.

SG
Tauchmann

 

Hi,

da du deinen korrigierten Code offensichtlich geheim halten möchstest ;), hier mal meine Lösung, falls andere User ein ähnliches Vorhaben realisieren möchten und nach einer Lösung suchen:

Code:

Option Explicit
Dim arrMappen()
Dim lngZaehler As Long

Sub Kopieren()
   OrdnerAuswahl "I:\Dokumente\"
   ' alle gefundenen Arbeitsmappen mit Pfad ausgeben
   Range("A1").Resize(UBound(arrMappen()) + 1, 1) = Application.Transpose(arrMappen())
End Sub

Sub OrdnerAuswahl(varSuchordner)
   Dim fso As Object
   Dim Ordner
   Dim UnterOrdner
   Dim strMappe As String
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set Ordner = fso.getfolder(varSuchordner)
   Application.ScreenUpdating = False
   For Each UnterOrdner In Ordner.subfolders
      ' 1. Mappe des Unterordners auf die Variable schreiben
      ' Variable ist leer wenn im Unterordner keine Arbeitsmappe vorhanden
      strMappe = Dir(UnterOrdner & "\*.xlsb")
      ' Schleife über alle Arbeitsmappen des Unterordners
      Do While strMappe <> ""
        ReDim Preserve arrMappen(0 To lngZaehler)
        arrMappen(lngZaehler) = UnterOrdner & "\" & strMappe
        lngZaehler = lngZaehler + 1
        strMappe = Dir
      Loop
      OrdnerAuswahl UnterOrdner
   Next
   Application.ScreenUpdating = True
   Set fso = Nothing
   Set Ordner = Nothing
End Sub

Bis später,
Karin