[Excel 2013][VBA] Ook in onderliggende mappen zoeken

tijmen_4real · 1 okt 2019

Hoi,

Via deze code zoek ik in een map naar bestanden. De VBA-code is nu:

Code:

Sub MergeAllWorkbooks()
    
    Dim SummarySheet As Worksheet
    Dim FolderPath As String
    Dim NRow As Long
    Dim FileName As String
    Dim WorkBk As Workbook
    Dim SourceRange As Range
    Dim DestRange As Range
    Dim datumAanmaak As Range
    Dim oFS As Object
    Dim creationDate As String

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Set SummarySheet = ThisWorkbook.Worksheets(1)
    Set oFS = CreateObject("Scripting.FileSystemObject")

    FolderPath = "locatie\map"

    NRow = 3
    FileName = Dir(FolderPath & "*.xlsm*")

    Do While FileName <> ""
        Set WorkBk = Workbooks.Open(FolderPath & FileName)
        'Z-nummer
        SummarySheet.Range("A" & NRow).Value = "Z-" & WorkBk.Worksheets(1).Range("D1")

        'naam grondstof
        Set SourceRange = WorkBk.Worksheets(1).Range("D6")
        
        'Datum document aangemaakt
        SummarySheet.Range("C" & NRow).Value = oFS.GetFile(WorkBk.FullName).DateCreated
        
        'deel A ondertekend
        If WorkBk.Worksheets(1).Range("R29").Value = "" Then
            SummarySheet.Range("D" & NRow).Value = "X"
        Else: SummarySheet.Range("D" & NRow).Value = "V"
        End If
        
        'deel B ondertekend
        If WorkBk.Worksheets(1).Range("R37").Value = "" Then
            SummarySheet.Range("E" & NRow).Value = "X"
        Else: SummarySheet.Range("E" & NRow).Value = "V"
        End If
        
        'deel C ondertekend
        If WorkBk.Worksheets(1).Range("R51").Value = "" Then
            SummarySheet.Range("F" & NRow).Value = "X"
        Else: SummarySheet.Range("F" & NRow).Value = "V"
        End If
        
        'deel D ondertekend
        If WorkBk.Worksheets(1).Range("R75").Value = "" Then
            SummarySheet.Range("G" & NRow).Value = "X"
        Else: SummarySheet.Range("G" & NRow).Value = "V"
        End If
        
        'deel E ondertekend
        If WorkBk.Worksheets(1).Range("R115").Value = "" Then
            SummarySheet.Range("H" & NRow).Value = "X"
        Else: SummarySheet.Range("H" & NRow).Value = "V"
        End If
        
        'deel F ondertekend
        If WorkBk.Worksheets(1).Range("R133").Value = "" Then
            SummarySheet.Range("I" & NRow).Value = "X"
        Else: SummarySheet.Range("I" & NRow).Value = "V"
        End If
        
        'deel G ondertekend
        If WorkBk.Worksheets(1).Range("R162").Value = "" Then
            SummarySheet.Range("J" & NRow).Value = "X"
        Else: SummarySheet.Range("J" & NRow).Value = "V"
        End If
        
        'deel H ondertekend
        If WorkBk.Worksheets(1).Range("R173").Value = "" Then
            SummarySheet.Range("K" & NRow).Value = "X"
        Else: SummarySheet.Range("K" & NRow).Value = "V"
        End If
        
        'deel I ondertekend
        If WorkBk.Worksheets(1).Range("R181").Value = "" Then
            SummarySheet.Range("L" & NRow).Value = "X"
        Else: SummarySheet.Range("L" & NRow).Value = "V"
        End If
        
        'deel J ondertekend
        If WorkBk.Worksheets(1).Range("R186").Value = "" Then
            SummarySheet.Range("M" & NRow).Value = "X"
        Else: SummarySheet.Range("M" & NRow).Value = "V"
        End If
        
        'deel K ondertekend
        If WorkBk.Worksheets(1).Range("R193").Value = "" Then
            SummarySheet.Range("N" & NRow).Value = "X"
        Else: SummarySheet.Range("N" & NRow).Value = "V"
        End If
        
        Set DestRange = SummarySheet.Range("B" & NRow)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
           SourceRange.Columns.Count)

        DestRange.Value = SourceRange.Value
        
        NRow = NRow + DestRange.Rows.Count

        WorkBk.Close SaveChanges:=False

        FileName = Dir()
    Loop

    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

Dit werkt prima voor de bestanden die direct in die map staan, maar ik wil graag dat er ook in onderliggende mappen gezocht wordt, als in "locatie\map\map1", "locatie\map\map2", etc.
Welke VBA-code is hier aanvullend voor nodig?

Groet,

Tijmen

edmoor · 1 okt 2019

Voorbeeld voor subfolders:

Code:

Public Sub LoopFolders()
    Dim fso, oFolder, oSubfolder, oFile, queue As Collection

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set queue = New Collection
    queue.Add fso.GetFolder("locatie\map") [COLOR="#008000"]'Vervangen door je eigen top folder[/COLOR]

    Do While queue.Count > 0
        Set oFolder = queue(1)
        queue.Remove 1
        For Each oSubfolder In oFolder.SubFolders
            queue.Add oSubfolder
        Next oSubfolder
        
        For Each oFile In oFolder.Files
            If Right(oFile.Name, 5) = ".xlsm" Then
                [COLOR="#008000"]'Doe hier je ding per xlsm bestand[/COLOR]
            End If
        Next oFile
    Loop
End Sub

tijmen_4real · 7 okt 2019

Ik kwam er niet uit om de code zo aan te passen dat het werkte.
Heb nu de twee delen samengevoegd, maar krijg een 1004-error:

Code:

Public Sub LoopFolders()
    Dim fso, oFolder, oSubfolder, oFile, queue As Collection
    Dim SummarySheet As Worksheet
    Dim FolderPath As String
    Dim NRow As Long
    Dim FileName As String
    Dim WorkBk As Workbook
    Dim SourceRange As Range
    Dim DestRange As Range
    Dim datumAanmaak As Range
    Dim oFS As Object
    Dim creationDate As String

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    Set SummarySheet = ThisWorkbook.Worksheets(1)
    Set oFS = CreateObject("Scripting.FileSystemObject")

    FolderPath = "mijn locatie staat normaliter hier"

    NRow = 3
    FileName = Dir(FolderPath & "*.xlsm*")

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set queue = New Collection
    queue.Add fso.GetFolder("H:\A. DUSART\4. KWALITEIT\QUALITY ASSURANCE\Z-nummers (aanvraag nieuwe grondstofleverancier ) +monsterlijst\Z-nummers aanvraag nieuwe grondstof-leveranciers\") 'Vervangen door je eigen top folder

    Do While queue.Count > 0
        Set oFolder = queue(1)
        queue.Remove 1
        For Each oSubfolder In oFolder.SubFolders
            queue.Add oSubfolder
        Next oSubfolder
        
        For Each oFile In oFolder.Files
            If Right(oFile.Name, 5) = ".xlsm" Then
                Set WorkBk = Workbooks.Open(FolderPath & FileName)
        'Z-nummer
        SummarySheet.Range("A" & NRow).Value = "Z-" & WorkBk.Worksheets(1).Range("D1")

        'naam grondstof
        Set SourceRange = WorkBk.Worksheets(1).Range("D6")

        'Datum document aangemaakt
        SummarySheet.Range("C" & NRow).Value = oFS.GetFile(WorkBk.FullName).DateCreated

        'deel A ondertekend
        If WorkBk.Worksheets(1).Range("R29").Value = "" Then
            SummarySheet.Range("E" & NRow).Value = "X"
        Else: SummarySheet.Range("E" & NRow).Value = "V"
        End If

        'deel B ondertekend
        If WorkBk.Worksheets(1).Range("R37").Value = "" Then
            SummarySheet.Range("F" & NRow).Value = "X"
        Else: SummarySheet.Range("F" & NRow).Value = "V"
        End If

        'deel C ondertekend
        If WorkBk.Worksheets(1).Range("R51").Value = "" Then
            SummarySheet.Range("G" & NRow).Value = "X"
        Else: SummarySheet.Range("G" & NRow).Value = "V"
        End If

        'deel D ondertekend
        If WorkBk.Worksheets(1).Range("R75").Value = "" Then
            SummarySheet.Range("H" & NRow).Value = "X"
        Else: SummarySheet.Range("H" & NRow).Value = "V"
        End If

        'deel E ondertekend
        If WorkBk.Worksheets(1).Range("R115").Value = "" Then
            SummarySheet.Range("I" & NRow).Value = "X"
        Else: SummarySheet.Range("I" & NRow).Value = "V"
        End If

        'deel F ondertekend
        If WorkBk.Worksheets(1).Range("R133").Value = "" Then
            SummarySheet.Range("J" & NRow).Value = "X"
        Else: SummarySheet.Range("J" & NRow).Value = "V"
        End If

        'deel G ondertekend
        If WorkBk.Worksheets(1).Range("R162").Value = "" Then
            SummarySheet.Range("K" & NRow).Value = "X"
        Else: SummarySheet.Range("K" & NRow).Value = "V"
        End If

        'deel H ondertekend
        If WorkBk.Worksheets(1).Range("R173").Value = "" Then
            SummarySheet.Range("L" & NRow).Value = "X"
        Else: SummarySheet.Range("L" & NRow).Value = "V"
        End If

        'deel I ondertekend
        If WorkBk.Worksheets(1).Range("R181").Value = "" Then
            SummarySheet.Range("M" & NRow).Value = "X"
        Else: SummarySheet.Range("M" & NRow).Value = "V"
        End If

        'deel J ondertekend
        If WorkBk.Worksheets(1).Range("R186").Value = "" Then
            SummarySheet.Range("N" & NRow).Value = "X"
        Else: SummarySheet.Range("N" & NRow).Value = "V"
        End If

        'deel K ondertekend
        If WorkBk.Worksheets(1).Range("R193").Value = "" Then
            SummarySheet.Range("O" & NRow).Value = "X"
        Else: SummarySheet.Range("O" & NRow).Value = "V"
        End If

        Set DestRange = SummarySheet.Range("B" & NRow)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
           SourceRange.Columns.Count)

        DestRange.Value = SourceRange.Value

        NRow = NRow + DestRange.Rows.Count

        WorkBk.Close SaveChanges:=False

        'SummarySheet.Range("D" & NRow).Hyperlinks.Add Anchor:=Selection, Address:=FolderPath & FileName, TextToDisplay:="Openen"

        FileName = Dir()
            End If
        Next oFile
    Loop
End Sub

Waarom? En hoe moet het wel zijn...?

[Excel 2013][VBA] Ook in onderliggende mappen zoeken

tijmen_4real

Gebruiker

edmoor

Inventaris

tijmen_4real

Gebruiker

Nieuwste berichten

Wij waarderen jouw privacy