Ouvrir un fenetre pour selectionner un dossier dans une macro

[orphelion]

Bonjour a tous, bonjour le forum,

Je dispose de toute une liste de fichiers excel que je souhaite compiler en un seul. Pour ce faire ,j'ai une macro qui me permet de fusionner les differentes feuilles excels une fois l'adresse specifiee au coeur de la macro.

Toutefois je souhaiterai rendre cette macro plus simple avec une fenetre qui apparait et propose a l'utilisateur de selection le dossier. Type appplication.openfile mais pour une dossier et integrer cette option a cette macro qui fusionne tous les fichiers.

Sub MergeSheets()
    Dim SrcBook As Workbook
    Dim fso As Object, f As Object, ff As Object, f1 As Object
       
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFolder[COLOR="red"]("C:\Folder Path")[/COLOR]    Set ff = f.Files
    
    For Each f1 In ff
        Set SrcBook = Workbooks.Open(f1)
        Range("A1:M" & Range("A65536").End(xlUp).Row).Copy
        ThisWorkbook.Worksheets(1).Activate
        Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Application.CutCopyMode = False
        SrcBook.Close
    Next
End Sub

J'ai trouve cette fonction mais je n'arrive pas a l'utiliser ...deja parce que c'est une fonction et quelle n'apparait plus dans les commandes macro :s

Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = strPath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function

En esperant avoir ete clair

Merci d'avance pour votre aide!

 

[Compte Supprimé 979]

Re : Ouvrir un fenetre pour selectionner un dossier dans une macro

Bonjour Orphelion

Voici le code modifié

Option Explicit
Sub MergeSheets()
  Dim SrcBook As Workbook
  Dim fso As Object, f As Object, ff As Object, f1 As Object
  Dim SPath As String
  Application.ScreenUpdating = False
  Set fso = CreateObject("Scripting.FileSystemObject")
  ' Ouvrir la boite de dialogue pour choix du dossier
  SPath = GetFolder("C:\")
  If SPath = "" Then Exit Sub
  ' Définir ce dossier par défaut dans FSO
  Set f = fso.GetFolder(SPath)
  Set ff = f.Files
  For Each f1 In ff
    Set SrcBook = Workbooks.Open(f1)
    Range("A1:M" & Range("A65536").End(xlUp).Row).Copy
    ThisWorkbook.Worksheets(1).Activate
    Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                                               :=False, Transpose:=False
    Application.CutCopyMode = False
    SrcBook.Close
  Next
End Sub
Function GetFolder(strPath As String) As String
  Dim fldr As FileDialog
  Dim sItem As String
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
  With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = strPath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
  End With
NextCode:
  GetFolder = sItem
  Set fldr = Nothing
End Function

A+

 

[orphelion]

Re : Ouvrir un fenetre pour selectionner un dossier dans une macro

Bonjour BrunoM45

je suis desole j'avais perdu le fil de cette discussion (et non pas l'interet pour une reponse a mon probleme ^^)

je viens de tester ta solution mais malheureusement j'ai une erreur en lancant le code:

'Sub Format_Results()
 Option Explicit
  Dim SrcBook As Workbook
  Dim fso As Object, f As Object, ff As Object, f1 As Object
  Dim SPath As String
  Application.ScreenUpdating = [B][COLOR="red"]False[/COLOR][/B] 
 Set fso = CreateObject("Scripting.FileSystemObject")
  ' Ouvrir la boite de dialogue pour choix du dossier
  SPath = GetFolder("C:\")
  If SPath = "" Then Exit Sub
  ' Définir ce dossier par défaut dans FSO
  Set f = fso.GetFolder(SPath)
  Set ff = f.Files
  For Each f1 In ff
    Set SrcBook = Workbooks.Open(f1)
    Range("A1:M" & Range("A65536").End(xlUp).Row).Copy
    ThisWorkbook.Worksheets(1).Activate
    Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                                               :=False, Transpose:=False
    Application.CutCopyMode = False
    SrcBook.Close
  Next
  End Sub
Function GetFolder(strPath As String) As String
  Dim fldr As FileDialog
  Dim sItem As String
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
  With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = strPath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
  End With
NextCode:
  GetFolder = sItem
  Set fldr = Nothing
End Function

Je ne sais pas comment resoudre cela... est ce que quelqu'un pourrait m'indiquer la source du probleme :?

merci d'avance!

ps: on notera que j'essaie de mettre des couleurs et du gras mais ca n'a pas l'air de fonctionner, je dois pas m'y prendre correctement...l'erreur se trouve sur:

Application.ScreenUpdating = False

 

[Compte Supprimé 979]

Re : Ouvrir un fenetre pour selectionner un dossier dans une macro

Orphelion, bonjour

Tu dois avoir un problème de référence manquante
Dans l'éditeur VBA -> Menu Outils -> Références -> [MANQUANTE] xxxxxx

Car l'instruction : Application.ScreenUpdating = False
Est tout à fait correcte

A+

PS : David si tu pouvais nous régler ce BUG de couleur dans le code ce serait cool

 

[orphelion]

Re : Ouvrir un fenetre pour selectionner un dossier dans une macro

BrunoM45,

merci pour ton aide.
effectivement cela fonctionne. Je n'ai pourtant rien changer mais il faut croire que mon excel avait besoin d'un peu de repos
ou alors c'etait moi ^^

a bientot!