Dialoogvenster

[jpvs]

Is het mogelijk een dialoogvenster op te roepen waar de directory in staat en te koppelen aan deze macro, kwestie van gemakkelijker te zoeken.


Application.FileDialog(msoFileDialogFolderPicker).Show

Sub CombineFiles()

Dim Path            As String
Dim FileName        As String
Dim Wkb             As Workbook
Dim WS              As Worksheet
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Path = "C:\" 'Change as needed
    FileName = Dir(Path & "\*.xls", vbNormal)
    Do Until FileName = ""
        Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
        For Each WS In Wkb.Worksheets
            WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        Next WS
        Wkb.Close False
        FileName = Dir()
    Loop
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

Dank bij voorbaat,

Pierre

 

[Wigi]

Pierre

Sub VraagMapOp()
    Dim fdMapOpvragen As FileDialog
    Set fdMapOpvragen = Application.FileDialog(msoFileDialogFolderPicker)
    With fdMapOpvragen
        .InitialFileName = "C:\"
        .Title = "Kies je map"
        If .Show Then MsgBox "Jij koos " & .SelectedItems(1), vbInformation
    End With
End Sub

Wigi

 

[jpvs]

Wigi,

heb wat aan het proberen geweest maar het lukt mij niet om de 2 macro's samen te voegen?

Pierre

 

[Wigi]

Pierre

Sub CombineFiles()

Dim Path            As String
Dim FileName        As String
Dim Wkb             As Workbook
Dim WS              As Worksheet
Dim fdMapOpvragen   As FileDialog

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    Set fdMapOpvragen = Application.FileDialog(msoFileDialogFolderPicker)
    With fdMapOpvragen
        .InitialFileName = "C:\"
        .Title = "Kies je map"
        If .Show Then Path = .SelectedItems(1)
    End With
    
    FileName = Dir(Path & "\*.xls", vbNormal)
    Do Until FileName = ""
        Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
        For Each WS In Wkb.Worksheets
            WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        Next
        Wkb.Close False
        FileName = Dir()
    Loop
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

Wigi

 

[jpvs]

Mega Honourable Senior Member Wim is zeker niets teveel.:thumb:

Thanks,

Pierre