Macro pour importer plusieurs classeurs fermes

[Delux]

Bonjour a tous,
(desole pour les accents je travaille sur QWERTY)

Grace a ce forum j'ai pu m'ameliorer dans la creation de macro et je vous en remercie.

Toutefois, je bloque actuellement sur la creation d'une macro qui me permettrait d'importer plusieurs classeurs excel (qui sont tous enregistres dans le meme dossier) dans un classeur general.

Voici le code que j'utilisais au debut, qui fonctionne tres bien pour 2 ou 3 classeurs, mais qui ne fonctionne pas pour le nombre important de classeurs que je possede desormais.

Sub Import_Find_Folder()

'Folder selection
Dim dossier As FileDialog
Dim dl As Integer

Application.EnableEvents = False

Set dossier = Application.FileDialog(msoFileDialogFolderPicker)
dossier.Show

If dossier.SelectedItems.Count > 0 Then pfile = dossier.SelectedItems(1) & "\" 'Path to saved excel files
nfile = Dir(pfile & "*.xls") 'ou xlsx ou xlsm (name of The document)

i = 10 'Activation de la deuxieme ligne
dl = Sheet1.Range("A65000").End(xlUp).Row + 1

Sheet1.Range("A10:Z65000").ClearContents

Do Until nfile = ""
    Sheet1.Range("Z1").Formula = "=COUNTA('" & pfile & "[" & nfile & "]sheet1'!$A$10:A500000)"
    j = Int(Range("Z1")) + i - 1
    Range("A" & i & ":C" & j - 1) = "='" & pfile & "[" & nfile & "]sheet1'!A10" 'imported range
    Range("I" & i & ":R" & j - 1) = "='" & pfile & "[" & nfile & "]sheet1'!I10"
    i = j
    nfile = Dir()
Loop

Range("Z1").Clear

With Range("A10:R60000")
    .Value = .Value
End With

End Sub

J'ai essaye de le modifier comme ceci, mais ca ne fonctionne pas... :/

Sub Import_Find_Folder2()

Dim dossier As FileDialog
Dim dl As Integer

Application.EnableEvents = False

Set dossier = Application.FileDialog(msoFileDialogFolderPicker)
dossier.Show

If dossier.SelectedItems.Count > 0 Then pfile = dossier.SelectedItems(1) & "\" 'Path to save excel files
nfile = Dir(pfile & "*.xls") 'ou xlsx ou xlsm (name of The document)

i = 10 'Activation de la deuxieme ligne
dl = Sheet1.Range("A65000").End(xlUp).Row + 1

Sheet1.Range("A10:Z" & dl).ClearContents

Do Until nfile = ""
    Workbooks(nfile).Sheets("Checking Form").Range("A10:R" & Workbooks(nfile).Sheets("Checking Form").Range("A65536").End(xlUp).Row).Copy ThisWorkbook.Sheets("MASTER").Range("A" & dl)
    Workbooks(nfile).Close
    
    nfile = Dir()
Loop

End Sub

Auriez-vous une suggestion pour ameliorer cette macro qui ne fonctionne pas ou alors une nouvelle macro?

En vous remerciant tous par avance.

Cordialement

Delux

 

[Yaloo]

Re : Macro pour importer plusieurs classeurs fermes

Bonsoir Delux,

Vois avec ton fichier modifié, ma macro est dans le Module1.

A te relire

Martial

PS ; j'en ai profité pour supprimer tes cellules vides, ton fichier passe de 1400 ko à 29 ko.

 

[ChTi160]

Re : Macro pour importer plusieurs classeurs fermes

Bonjour delux
Bonjour le Fil
Bonjour le forum

je suis parti du principe que les fichiers Source comportaient "DJM" dans leur Nom (A confirmer) et qu'ils se trouvaient dans le même dossier .

j'ai un peu modifié la procédure de Yaloo !

ci dessous la Macro

Option Explicit
Sub Import_fichier_2()
Dim Temp$
Dim DerLgn_S As Integer 'derniere ligne Source classeur "*" & "DJM" & "*"
Dim DerLgn_C As Integer ''derniere ligne classsuer Cible "Active"
Dim DerCol As Byte
Dim tbl
Const First_Row As Byte = 10 'on définie la ligne de debut de la feuille cible

      With Application
          .ScreenUpdating = False
          .DisplayAlerts = False
          .Calculation = xlCalculationManual
      End With
      Temp = Dir(ActiveWorkbook.Path & "\*.xls*")
      With ThisWorkbook.Sheets("MASTER")
            DerLgn_C = .Cells(.Rows.Count, 1).End(xlUp)(2).Row ' on determine la derniere ligne non vide (limite 10)
              DerCol = .Cells(9, .Columns.Count).End(xlToLeft).Column ' ici on détermine la derniere colonne Non vide de la ligne 9
                .Range(.Cells(First_Row, 1), .Cells(DerLgn_C, DerCol)).ClearContents 'on efface la plage ainsi définie
      End With
      Do While Temp <> "" 'effectuer tans que non vide

            If Temp Like "*" & "DJM" & "*" Then 'si le nom du classeur contient "DJM"
                  With ThisWorkbook.Sheets("MASTER") 'avec le classeur cible
                        DerLgn_C = .Cells(.Rows.Count, 1).End(xlUp)(2).Row 'on determine la derniere ligne non vide du classeur ou l'on va coller les donnees récupérées
                  End With
                  
                  Workbooks.Open Filename:=ThisWorkbook.Path & "\" & Temp 'on ouvre le classeur source trouvé
                  With ActiveSheet 'avec la deuille active de ce Classeur
                        DerLgn_S = .Cells(.Rows.Count, 1).End(xlUp)(2).Row 'on détermine la derniere ligne non vide de la colonne 1 en partant du Bas
                        DerCol = .Cells(9, .Columns.Count).End(xlToLeft).Column 'on détermine la derniére colonne non vide de la ligne 9 en partant de la droite
                        tbl = .Range(.Cells(First_Row, 1), .Cells(DerLgn_S, DerCol)).Value 'on récupére les données de la plage ainsi définie
                  End With
                  Workbooks(Temp).Close False 'on ferme le classeur source 
                  With ThisWorkbook.Sheets("MASTER") 'avec la feuille cible
                        .Cells(DerLgn_C, 1).Resize(UBound(tbl, 1), UBound(tbl, 2)) = tbl 'on colle les données du tableau temporaire a partir de la cellule définie ".Cells(DerLgn_C, 1)"
                  End With
            End If
Set tbl= nothing 'on vide le tableau temporaire
            Temp = Dir 
      Loop 'on boucle
      With Application
          .ScreenUpdating = True
          .DisplayAlerts = True
          .Calculation = xlCalculationAutomatic
      End With

End Sub

tu testes et tu nous dit
Bonne journée
Amicalement
Jean Marie