Kapali excel dosyalarindan çoklu aktarmada klasor seçimi

[byvolkan]

Iyi gunler elimde asagidaki gibi bir makro var ve gayet guzel çalisiyor.
Benim iki problemim var.
Birincisi, dosya yolunu maalesef sadece makronun içerisinde belirtilen : C:\Users\DATA\olarak kullanabiliyoruz.
Bu dosya yolunu her kullanisimizda farkli bir dosya yolu olarak manuel bir sekilde kendimizin seçmesi için nasil bir ekleme yapmamiz gerekli?

ikincisi ise makro *.xlsx formatli bir excel klasoru yoksa *.xls formatina geçis yapmadan direk duruyor yani: Fichier = Dir("*.xls") komutunda tek bir dosya türü için arama yapiyor.
Yardimlariniz için tesekkur ederim.

Sub import_auto()
Dim principal As ThisWorkbook
Dim repertoire As String, fichier As String
    Application.ScreenUpdating = False
    Set principal = ThisWorkbook
    repertoire = "C:\Users\DATA\"
    ChDir repertoire
    fichier = Dir("*.xlsx; *.xlsm; *.xlsa; *.xls")
    Do While fichier <> ""
        If fichier <> principal.Name Then
            Workbooks.Open fichier
            On Error GoTo suivant
            With Sheets(1)
                On Error GoTo 0
                On Error Resume Next
           
                .Range("A1:A" & .[b65536].End(xlUp).Row) = Left(fichier, Len(fichier) - 4)
                .UsedRange.EntireRow.Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1)
            End With
            ActiveWorkbook.Close False
        End If
suivant:
        If Err.Number = 9 Then MsgBox "Pas de feuille ""1"" dans le fichier " & fichier, vbExclamation: ActiveWorkbook.Close False
        fichier = Dir
    Loop
End Sub

 

[byvolkan]

Tam anlatamamis olabilirim su sekilde sorayim
repertoire = "C:\Users\DATA\"
bu kismi kendimiz mauel olarak seçebilirmiyiz?

 

[byvolkan]

Forumda arama yaptim bu konuyla ilgili ama pek bir sey bulamadim. En azindan bu konuyla ilgili orenek yada kaynak bulabilecegim bildiginiz bir konu basligi varmi. Yardimci olursaniz sevinirim.

 

[veyselemre]

Sub import_auto()
    Dim principal As ThisWorkbook
    Dim repertoire As String, fichier As String
    Dim FldrPicker As FileDialog

    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
        .Title = "Select A Target Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        repertoire = .SelectedItems(1) & "\"
    End With

    Application.ScreenUpdating = False
    Set principal = ThisWorkbook
 
    fichier = Dir(reportoire & "*.xls?")
    Do While fichier <> ""
        If fichier <> principal.Name Then

            Workbooks.Open fichier
            On Error GoTo suivant
            With Sheets(1)
                On Error GoTo 0
                On Error Resume Next
          
                .Range("A1:A" & .[b65536].End(xlUp).Row) = Left(fichier, Len(fichier) - 4)
                .UsedRange.EntireRow.Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1)
            End With
            ActiveWorkbook.Close False
        End If
suivant:
        If Err.Number = 9 Then MsgBox "Pas de feuille ""1"" dans le fichier " & fichier, vbExclamation: ActiveWorkbook.Close False
        fichier = Dir
    Loop
End Sub

 

[byvolkan]

Sub import_auto()
    Dim principal As ThisWorkbook
    Dim repertoire As String, fichier As String
    Dim FldrPicker As FileDialog

    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
        .Title = "Select A Target Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        repertoire = .SelectedItems(1) & "\"
    End With

    Application.ScreenUpdating = False
    Set principal = ThisWorkbook

    fichier = Dir(reportoire & "*.xls?")
    Do While fichier <> ""
        If fichier <> principal.Name Then

            Workbooks.Open fichier
            On Error GoTo suivant
            With Sheets(1)
                On Error GoTo 0
                On Error Resume Next
         
                .Range("A1:A" & .[b65536].End(xlUp).Row) = Left(fichier, Len(fichier) - 4)
                .UsedRange.EntireRow.Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1)
            End With
            ActiveWorkbook.Close False
        End If
suivant:
        If Err.Number = 9 Then MsgBox "Pas de feuille ""1"" dans le fichier " & fichier, vbExclamation: ActiveWorkbook.Close False
        fichier = Dir
    Loop
End Sub

Cok tessekkur ederim super olmus. Elinize emeginize saglik.