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:
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:
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
[COLOR="#FF0000"]fpath = Workbooks("" & RimorMacro & "").Sheets("StartPunt").Range("C3").Value[/COLOR] '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
[COLOR="#FF0000"]spath = Range("C3").Value[/COLOR]
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
