zoeken in subfolders binnen een directory

[thebute]

Goedemiddag allemaal

Ik heb een hulp gekregen om een code in mekaar te zetten maar helaas kan met deze code niet gezocht worden in Sub-Folders
Kan iemand deze code voor mij zo aanpassen dat het wel lukt in subfolders te zoeken?

Ik heb een link naar het betreffende bestand op mijn GoogleDrive geplaatst. De module waar het om gaat heet MasterFile:
https://drive.google.com/file/d/0B06UUoORgT0VZ2NvQmRFTDJ5aXM/edit?usp=sharing


alvast dank

Dim vFiles As Variant


Sub DossierNummer()
  Dim RimorMacro As String
  Dim mysht As String

  Application.ScreenUpdating = False

  RimorMacro = ActiveWorkbook.Name
  Sheets("OverzichtInhoud").Select
  Range("A2:Q2" & ActiveSheet.UsedRange.Rows.Count).ClearContents
  Range("A2").Select


  Sheets("StartPunt").Select


  get_filename
  Sheets("StartPunt").Select
  lrow = Range("E1", Selection.End(xlDown)).Count
 
  For i = 2 To lrow
    If Range("E" & i).Value = "" Then
      MsgBox "Gegevens staan nu klaar in de OverzichtInhoud!", vbInformation, "Status Kopiëren"
      Exit Sub
    Else
      Workbooks.Open Filename:=vFiles(1, i) & vFiles(2, i)
  
      mysht = ActiveWorkbook.Name
        Application.StatusBar = "Rimor RapportageTool is bezig met het verwerken van: " & mysht
            
            Sheets("Worksheet").Select
                Range("B4:B10,B29,B20,B24,B30,B31,B32,B33,B34,B35,B36").Select
                    Selection.Copy
                
      Workbooks(RimorMacro).Activate
      Sheets("OverzichtInhoud").Select
      Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True
  
      ActiveCell.Offset(0, 0).Select
        Workbooks("" & mysht & "").Activate
            Range("B24").Select
 
ActiveCell.Offset(0, 0).Select
    Workbooks("" & mysht & "").Activate
        Range("B24").Select
 
Selection.End(xlDown).Select
Selection.Copy
Workbooks("" & RimorMacro & "").Activate
Selection.PasteSpecial Paste:=xlPasteValues
ActiveCell.Offset(1, 0).Select
Application.CutCopyMode = False
Sheets("StartPunt").Select
      
      Workbooks(mysht).Close SaveChanges:=False
      Workbooks(RimorMacro).Activate
    End If
  Next i
  Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub




Sub get_filename()
  Const sPathRange As String = "C3,C7"
  Const iIncr As Long = 50

  Dim fdr As String
  
  ' this range will store your paths
  Dim rngPathList As Excel.Range
  Dim rng As Excel.Range
  
  Dim iSize As Long

  iSize = iIncr
  
  mrow = 2
  
  ReDim vFiles(1 To 2, 2 To iSize)
  
  Set rngPathList = Range(sPathRange)
  
  Range(Range("E2"), Range("E2").End(xlDown)).ClearContents
  Range("E2").Select
  
  For Each rng In rngPathList
    spath = rng.Value
    fdr = Dir(spath & "\*Worksheet*.xlsm")
    
    Do While fdr <> ""
      If mrow > iSize Then
        iSize = iSize + iIncr
        ReDim Preserve vFiles(1 To 2, 2 To iSize)
      End If

      vFiles(1, mrow) = spath & Application.PathSeparator
      vFiles(2, mrow) = fdr
      
      Cells(mrow, 5).Value = fdr
      
      fdr = Dir
      mrow = mrow + 1
    Loop
    
    If iSize >= mrow Then
      iSize = mrow - 1
      ReDim Preserve vFiles(1 To 2, 2 To iSize)
    End If
  Next rng
End Sub

groet
thebute

 

[Elsendoorn2134]

thebute

Ik heb een bestand voor je dat vanaf een bepaald punt (bijvoorbeeld C:\Documents\) kan zoeken in alle sub folders.
In dit voorbeeld zoekt hij bijvoorbeeld alle PDF bestanden.
Ik denk dat je op basis van dit voorbeeld je eigen code kan aanpassen.

Veel Succes.

Bekijk bijlage HelpMijBestandZoeken.xlsm

 

[thebute]

Elsendoorn2134

Mijn vba skills is nog niet zo ver ben ik bang dat ik een aanpassing hierin zelf kan aanbrengen.
simpele macros opnemen lukt (met behulp van forum users) maar de macro in het bestand dat je hebt toegevoegd hebt is voor mij nu nog te moeilijk.
is het mogelijk mijn code aan te passen zodat wel lukt?

alvast dank

thebute

 

[snb]

Dat kan ook veel simpeler:
Alle .xlsm bestanden in G: en subfolders in kolom K

sub M_snb()
  sn=split(createobject("wscript.shell").exec("cmd /c Dir ""G:\*.xlsm"" /b /s").stdout.readall,vbcrlf)
  cells(1,11).resize(ubound(sn)+1)=application.transpose(sn)
end sub

PS. Een goed VBA handboek doornemen kan ook zeker geen kwaad.

 

[thebute]

Hi snb,

het bestand (RapportageTool) van waaruit ik werk heeft een hoofdpagina "StartPunt".
Hier worden twee directories gespecificeerd (in cellen C3 en C7).
De beide directories bevatten submappen van verschillende klanten met daarin allerlei bestanden waarvan 1 of meerdere xlsm workbooks met naam 'Worksheet'.

De RapportageTool zoek voor xlsm bestanden met naam 'Worksheet' direct binnen de de gespecificeerde directories in cellen C3 en C7 maar zoekt niet in de onderliggende mappen.

de code die jij meegeeft lijkt een nieuwe sub procedure te zijn. Dit terwijl ik denk dat de aanpassing die ik zoek binnen de al bestaande "DossierNummer" procedure en "get_filename" procedure moet gebeuren. Beide procedures zijn te vinden in de 'Masterfile' module

Ik hoop dat het niet al te moeilijk is maar ik zou het echt mooi vinden als iemand dit compleet zou kunnen maken.

alvast dank
thebute

het bestand is te downloaden vanaf mijn GoogleDrive:
https://drive.google.com/file/d/0B06UUoORgT0VZ2NvQmRFTDJ5aXM/edit?usp=sharing

 

[snb]

Daarvoor is in mijn ogen dit soort forums niet: wij helpen je je eigen oplossingen te maken.
Als je een automatiseringsopdracht hebt kun je natuurlijk altijd iemand tegen betaling inschakelen. Misschien weet ik wel iemand .