selection multi fichiers

Version imprimable

Bonjour,
Je cherche à finaliser une macro vba sous excel qui permet de sélectionner plusieurs fichiers excel puis copier des cellules des fichiers sélectionnés et coller dans le fichier pilote qui contient la macro qui s’appelle « ouverture multi fichiers.xls ».
La macro fonctionne correctement avec le 1er fichier sélectionné puis bug pour le fichier suivant avec une erreur 424 sur l’instruction Workbooks.Open FileName:=NomduFichier(i).
Un GRAND Merci d’avance pour vos tuyo !
Jojo :D

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
Sub ChargementMultiFichiers()
    Dim Filt As String
    Dim FilterIndex As Integer
    Dim NomduFichier As Variant
    Dim Title As String
    Dim i As Integer
 
'   Descriptif extensions fichiers
    Filt = "Text Files (*.txt),*.txt," & _
            "Lotus Files (*.prn),*.prn," & _
            "Comma Separated Files (*.csv),*.csv," & _
            "ASCII Files (*.asc),*.asc," & _
            "All Files (*.*),*.*"
'   Display *.* by default
    FilterIndex = 5
'   Donne le titre de la boite de dialogue
    Title = "Selectionner le fichier"
'   Récupération des noms de fichiers
    NomduFichier = Application.GetOpenFilename _
        (FileFilter:=Filt, _
         FilterIndex:=FilterIndex, _
         Title:=Title, _
         MultiSelect:=True)
 
'   Exit si annule boite dialogue
    If Not IsArray(NomduFichier) Then
        MsgBox "Aucun fichier sélectionné."
        Exit Sub
    End If
 
'Renvoie le chemin et noms des fichiers sélectionnés
    For i = LBound(NomduFichier) To UBound(NomduFichier)
Workbooks.Open FileName:=NomduFichier(i)
Set NomduFichier = ActiveWorkbook 'Enregistre le nom du fichier ouvert
Range("A1:A10").Copy 'copie les cellules A1:A10 du fichier sélectionné
Windows("ouverture multi fichiers.xls").Activate
Sheets("Feuil1").Select
'recherche cellule vide et colle la sélection dans le fichier collecteur "ouverture multi fichiers.xls"
Range("A1").Select
Do While ActiveCell.Value <> ""
ActiveCell.Offset(1, 0).Range("A1").Select
Loop
ActiveCell.Select
ActiveSheet.Paste
 
Application.DisplayAlerts = False
NomduFichier.Close SaveChanges:=False
Application.DisplayAlerts = True
 Next i
 End Sub

11/02/2011, 20h14
Theze
Bonsoir Jojo3150,

A mon sens, l'erreur vient de la ré-affectation de la variable "NomduFichier" car d'un objet Array tu en fait un objet Workbook et donc, plus de tableau de fichier :
Code:

1 2 Set NomduFichier = ActiveWorkbook
Hervé.
12/02/2011, 11h40
Jojo3150

Bonjour,
Quelqu'un a t'il une solution à me proposer?
la macro fonctionne pour le chargement du 1er fichier puis j'ai l'impression qu'il perd le nom des autre fichiers en route....
Help Siouplet:calim2:
Jojo

As tu compris la réponse de Thèse?
essaies comme ceci

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Sub ChargementMultiFichiers()
Dim i As Integer
Dim Wb As Workbook
Dim Sh As Worksheet
Dim NewLig As Long
Dim FilterIndex As Byte
Dim NomduFichier As Variant
Dim Title As String, Filt As String
 
'   Descriptif extensions fichiers
Filt = "Text Files (*.txt),*.txt," & "Lotus Files (*.prn),*.prn," & "Comma Separated Files (*.csv),*.csv," & "ASCII Files (*.asc),*.asc," & "All Files (*.*),*.*"
'   Display *.* by default
FilterIndex = 5
'   Donne le titre de la boite de dialogue
Title = "Selectionner le fichier"
'   Récupération des noms de fichiers
NomduFichier = Application.GetOpenFilename(FileFilter:=Filt, FilterIndex:=FilterIndex, Title:=Title, MultiSelect:=True)
 
'   Exit si annule boite dialogue
If Not IsArray(NomduFichier) Then
   MsgBox "Aucun fichier sélectionné."
Else
   Application.ScreenUpdating = False
   Set Sh = ThisWorkbook.Worksheets("Feuil1")
   'Renvoie le chemin et noms des fichiers sélectionnés
   For i = LBound(NomduFichier) To UBound(NomduFichier)
      Set Wb = Workbooks.Open(NomduFichier(i))
      NewLig = Sh.Cells(Sh.Rows.Count, "A").End(xlUp).Row + 1
      Worksheets(1).Range("A1:A10").Copy Sh.Range("A" & NewLig)  'copie les cellules A1:A10 du fichier sélectionné
      Wb.Close SaveChanges:=False
   Next i
   Set Wb = Nothing
   Set Sh = Nothing
End If
End Sub

12/02/2011, 15h44
Jojo3150

Choupère ca marche!

Bonjour Mercatog,

Ton code fonctionne parfaitement bien!:ccool:
Un GRAND MERCI à toi et à Theze.:P

Jojo