Cell string for multiple directoires /search multiple directoires

[thebute]

Hi Everyone


Im new to VBA and have tried puting together a code from different places.
In the current code one search is being executed from the directory mentioned in cell C3
what I'm looking for is a second directory from an other cell - C4

So the code would include a search in two directories. one mentioned in cell C3 and the other in cell C4

Hope this helps

Thanks in advance for all help


here is the code:

Sub DossierNummer()

ScreenUpdating = False

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

Sheets("StartPunt").Select
    lrow = Range("E1", Selection.End(xlDown)).Count 'Dit is bedoeld om de namen van alle gekopieerde docs aan te geven, beginnend bij Cell E1 in Werkblad StartPunt
    fpath = Workbooks("" & RimorMacro & "").Sheets("StartPunt").Range("C3").Value 'fpath is geeft de locatie aan waar gezocht wordt naar alle te kopieren bestanden


    get_filename
For i = 2 To lrow
    If Range("E" & i).Value = "" Then 'startend vanaf E1 begint Excel vanaf de tweede cell beneden met het invullen van de namen van alle te kopieren bestanden. Waar Excel op een gegveen moment geen bestanden meer heeft en dus een lege cell heeft, stopt de Macro en wordt er een bericht gegenereerd.
        MsgBox "Gegevens staan nu klaar in de OverzichtInhoud!", vbInformation, "Status Kopiëren"
Exit Sub

Else

Fname = Workbooks("" & RimorMacro & "").Sheets("StartPunt").Cells(i, 5).Value 'Alle bestanden die Excel mbv de macro hierboven heeft gevonden en in Column E heeft geplaatst gaat hij nu 1voor1 af.
    Workbooks.Open Filename:=fpath & "\" & Fname

        mysht = ActiveWorkbook.Name
        Sheets("Worksheet").Select '...Voor elk wb die excel vind selecteert hij ws "Worksheet"
            Range("B4:B10,B29,B20,B24,B30,B31,B32,B33,B34,B35,B36").Select '...gaat hij een aantal taken uitvoeren. hier bijvoorbeeld, gaat hij een rage cellen selecteren
                Selection.Copy 'hier heeft hij aan de ranges te kopieren

Workbooks("" & RimorMacro & "").Activate '...vervolgens gaat hij, nadat hij de Worksheets heeft gekopieerd, terug naar de RapportageTool
    Sheets("OverzichtInhoud").Select 'Terug in de RapportageTool kiest excel het juiste werkblad
        Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True 'Nu plakt excel de data in rijvorm in plaaats van onder elkaar

'ActivecellOffset>eerste deel is bedoeld om aan te geven hoeveel regels er tussen de waarden moet komen
'In dit geval 0 geeft aan direct op de volgende regel eronder
'De tweede 0 geeft aan dat de waarde direct in de eerste colum moet worden geplaatst

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 & "").Activate
Application.DisplayAlerts = False
ActiveWorkbook.Close
Workbooks("" & RimorMacro & "").Activate
End If
Next
End Sub
Sub get_filename()
Dim fdr As String
mrow = 2
RimorMacro = ActiveWorkbook.Name
spath = Range("C3").Value
Range("E2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("E2").Select
fdr = Dir(spath & "\*Worksheet*.xlsm")
Do While fdr <> ""
Cells(mrow, 5).Value = fdr
fdr = Dir
mrow = mrow + 1
Loop
End Sub

 

[iliace]

Hi,

Your code is difficult to read (at least it was a few minutes ago). But, if I understand correctly this will solve your issue. I highlight in bold red the parts I added.

Sub get_filename()
  Const sPathRange As String = "C3:C4"


  Dim fdr As String
  
  ' this range will store your paths
  Dim rngPathList As Excel.Range
  Dim rng As Excel.Range
  
  mrow = 2
  
  RimorMacro = ActiveWorkbook.Name
  
  Set rngPathList = Range(sPathRange)
  
  Range("E2").Select
  Range(Selection, Selection.End(xlDown)).Select
  Selection.ClearContents
  Range("E2").Select
  
  For Each rng In rngPathList
    spath = rng.Value
    fdr = Dir(spath & "\*Worksheet*.xlsm")
    
    Do While fdr <> ""
      Cells(mrow, 5).Value = fdr
      fdr = Dir
      mrow = mrow + 1
    Loop
  Next rng
End Sub

On a side note - I highly recommend you do some clean up on the code in the main procedure. There is way too much unnecessary selecting, etc. You can definitely cut that code down by half (at a minimum) and speed up execution time tenfold.

 

[thebute]

Thanks a bunch iliance,

The code you provided works like a charm.
It now returns all "Worksheets" in the specified dir in cell C3 & C4 (now changed fromC4 to C7)
I have also cleaned up my code so that it can be better read.

From the main sub "Sub DossierNummer()" the macro is generating an error. It seems that its not pulling the "Worksheets" from the second Dir specified in Cell C7

It is however pulling, copying, and pasting from the first Dir specified in Cell C3, but not C7

can you guide me to a solution in completing the code:

here is the code, including the amende version *(Sub get_filename()* you provided

thanks again in advance

Sub DossierNummer()
ScreenUpdating = False
RimorMacro = ActiveWorkbook.Name
    Sheets("OverzichtInhoud").Select
        Range("A2:Q2" & ActiveSheet.UsedRange.Rows.Count).ClearContents
            Range("A2").Select
Sheets("StartPunt").Select
    lrow = Range("E1", Selection.End(xlDown)).Count 
    fpath = Workbooks("" & RimorMacro & "").Sheets("StartPunt").Range("C3,C7").Value 
    get_filename
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
Fname = Workbooks("" & RimorMacro & "").Sheets("StartPunt").Cells(i, 5).
    Workbooks.Open Filename:=fpath & "\" & Fname
        mysht = ActiveWorkbook.Name
        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 & "").Activate
Application.DisplayAlerts = False
ActiveWorkbook.Close
Workbooks("" & RimorMacro & "").Activate
End If
Next
End Sub
 

Sub get_filename()
[B]  Const sPathRange As String = "C3:C4"[/B]
 
 
  Dim fdr As String
 
  ' this range will store your paths
[B]  Dim rngPathList As Excel.Range[/B]
[B]  Dim rng As Excel.Range[/B]
 
  mrow = 2
 
  RimorMacro = ActiveWorkbook.Name
 
[B]  Set rngPathList = Range(sPathRange)[/B]
 
  Range("E2").Select
  Range(Selection, Selection.End(xlDown)).Select
  Selection.ClearContents
  Range("E2").Select
 
[B]  For Each rng In rngPathList[/B]
[B]    spath = rng.Value[/B]
    fdr = Dir(spath & "\*Worksheet*.xlsm")
   
    Do While fdr <> ""
      Cells(mrow, 5).Value = fdr
      fdr = Dir
      mrow = mrow + 1
    Loop
[B]  Next rng[/B]
End Sub

Hi,

Your code is difficult to read (at least it was a few minutes ago). But, if I understand correctly this will solve your issue. I highlight in bold red the parts I added.

Sub get_filename()
  Const sPathRange As String = "C3:C4"


  Dim fdr As String
  
  ' this range will store your paths
  Dim rngPathList As Excel.Range
  Dim rng As Excel.Range
  
  mrow = 2
  
  RimorMacro = ActiveWorkbook.Name
  
  Set rngPathList = Range(sPathRange)
  
  Range("E2").Select
  Range(Selection, Selection.End(xlDown)).Select
  Selection.ClearContents
  Range("E2").Select
  
  For Each rng In rngPathList
    spath = rng.Value
    fdr = Dir(spath & "\*Worksheet*.xlsm")
    
    Do While fdr <> ""
      Cells(mrow, 5).Value = fdr
      fdr = Dir
      mrow = mrow + 1
    Loop
  Next rng
End Sub

On a side note - I highly recommend you do some clean up on the code in the main procedure. There is way too much unnecessary selecting, etc. You can definitely cut that code down by half (at a minimum) and speed up execution time tenfold.

 

[iliace]

This is the line that specifies the range:

Const sPathRange As String = "C3:C4"

So if you need it to be, C3:C7 instead, then the new code will be:

Const sPathRange As String = "C3:C7"

 

[thebute]

Hi iliace,
Indeed. I have also updated the code accordingly but even so the macro is still not pulling the files from the directory specified in C7.
The List however that is being being generated (with all found Worksheets) is working perfrect.

Is there a way for you the complete the code for me?
I was made to understand that the two sub procedures can also be combined into one but honestly spreaking I have no idea where to start.
Hopefully you (or maybe someone else) can help.
This is the code currently:

Sub DossierNummer()
 
ScreenUpdating = False
 
RimorMacro = ActiveWorkbook.Name
    Sheets("OverzichtInhoud").Select
        Range("A2:Q2" & ActiveSheet.UsedRange.Rows.Count).ClearContents
            Range("A2").Select
 Sheets("StartPunt").Select
    lrow = Range("E1", Selection.End(xlDown)).Count 
    fpath = Workbooks("" & RimorMacro & "").Sheets("StartPunt").Range("C3,C7").Value 
  
    get_filename
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
 
Fname = Workbooks("" & RimorMacro & "").Sheets("StartPunt").Cells(i, 5).Value
    Workbooks.Open Filename:=fpath & "\" & Fname
 
        mysht = ActiveWorkbook.Name
        Sheets("Worksheet").Select 
            Range("B4:B10,B29,B20,B24,B30,B31,B32,B33,B34,B35,B36").Select 
                Selection.Copy 'hier heeft hij aan de ranges te kopieren
 
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 & "").Activate
Application.DisplayAlerts = False
ActiveWorkbook.Close
Workbooks("" & RimorMacro & "").Activate
End If
Next
End Sub
Sub get_filename()
  Const sPathRange As String = "C3,C7"
 
 
  Dim fdr As String
 
  ' this range will store your paths
  Dim rngPathList As Excel.Range
  Dim rng As Excel.Range
 
  mrow = 2
 
  RimorMacro = ActiveWorkbook.Name
 
  Set rngPathList = Range(sPathRange)
 
  Range("E2").Select
  Range(Selection, Selection.End(xlDown)).Select
  Selection.ClearContents
  Range("E2").Select
 
  For Each rng In rngPathList
    spath = rng.Value
    fdr = Dir(spath & "\*Worksheet*.xlsm")
   
    Do While fdr <> ""
      Cells(mrow, 5).Value = fdr
      fdr = Dir
      mrow = mrow + 1
    Loop
  Next rng
End Sub

 

[iliace]

I would recommend against combining the two procedures into one. They perform distinct tasks, and should be kept modular - that's just good coding practice.

However, I think your problem might be because this line:

  lrow = Range("E1", Selection.End(xlDown)).Count

should be called after you run get_filename. So that section of the code should be:

  fpath = Workbooks("" & RimorMacro & "").Sheets("StartPunt").Range("C3,C7").Value
  
  get_filename

  Sheets("StartPunt").Select
  lrow = Range("E1", Selection.End(xlDown)).Count

 

[thebute]

Hi iliace

thanks again for all the effort you have put in to help me complete this file. unfortunately the error still exists.
since the site (or maybe my account) doesnt allow attachhments, I have uploaded the file in question to my Googledrive

please find below the link:
I hope by providing the file this will give better insight on the problem im facing

again thanks
thebute

https://drive.google.com/file/d/0B06UUoORgT0VZjlaVTNJcTBuem8/edit?usp=sharing
https://drive.google.com/file/d/0B06UUoORgT0VZjlaVTNJcTBuem8/edit?usp=sharing

 

[iliace]

OK, I think I found the problem.

The issue is that when you assign the multi-range value to fpath, it only takes the first one. Then it can't find any of the files in folder C7, because it's still looking in folder C3. But you weren't seeing the error because of this setting:

Application.DisplayAlerts = False

I modified your code somewhat - cleaned up some, and added a variant array that keeps track of both the file and the path it's stored in. I highlighted in red the parts I added. Other sections where you don't need to select, you will notice I shortened the code and removed some redundant code. So here is the entire MasterFile module code:

Dim vFiles As Variant


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

  '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
      Debug.Print "Processing " & mysht
      
      '...Voor elk wb die excel vind selecteert hij ws "Worksheet"
      'hier heeft hij aan de ranges te kopieren
      Sheets("Worksheet").Range("B4:B10,B29,B20,B24,B30,B31,B32,B33,B34,B35,B36").Copy
  
      Workbooks(RimorMacro).Activate
      Sheets("OverzichtInhoud").Select
      Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True
  
      Workbooks(mysht).Activate
      Range("B24").End(xlDown).Copy
      
      Workbooks(RimorMacro).Activate
      Selection.PasteSpecial Paste:=xlPasteValues
      
      ActiveCell.Offset(1, 0).Select
      
      Application.CutCopyMode = False
      
      Sheets("StartPunt").Select
      
      Workbooks(mysht).Close
      Workbooks(RimorMacro).Activate
    End If
  Next i
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

You will also see in the Immediate window the file that is currently being processed. Try it out and post back on the results.

 

[thebute]

Hi iliace,

The code you provided really works.
Up untill today I was having trouble sleeping because i realy wanted to find a solution.
so at night i would be thinking about all different options, but you nailed it. thank you very much - also for speeding up the process by your code-clean. wonderful!

I just added one code so that the files will close without saving.
This was done because for each file i was being promped to save or dont save.

You mentioned that i would see an immediate window stating that the file is currently being processed. It could be that Im missing this because of the speed in which the files are being processed. when processed each filed is shown on screen, including the cells that are copied and how the data is pasted into the worksheet "OverzichtInhoud". is there a way to prevent this from being shown?

if not, thats ok. Im greatful already for all you have done for me iliace

thebute

 

[iliace]

At the beginning of the main procedure (DossierNummer), add this line:

Application.ScreenUpdating = False

Replace this line:

Debug.Print "Processing " & mysht

with this:

Application.StatusBar = "Processing " & mysht

At the very end of the procedure (below Next i), add these two lines:

Application.StatusBar = False
Application.ScreenUpdating = True