Lister et récupérer plusieur donnés d'un dossier

Le 08/04/2015 à 13:52

Salut ThauThème,

Merci pour ta réponse rapide.

Peux tu me dire pourquoi au bout d'un moment j'obtient une erreur d'exécution 13 , incompatibilité de type sur la ligne DEST.Resize...

Au pire, je peux faire la mise en page moi-même

Merci encore

Le 08/04/2015 à 14:38

Bonjour Benjamin, bonjour le forum,

Je n'avais pas prévu le cas où l'onglet rapport ne contiendrait aucune donnée. C'est peut-être cela le problème. Le code modifié avec un début de mise en forme :

Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim CH As String 'déclare la variable CH (CHemin d'accès)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim NF As String 'déclare la variable NF (Nom du Fichier)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim DL As Integer 'déclare la variable DL (Dernière ligne)
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim K As Integer 'déclare la variable K (incrément)
Dim I As Integer 'déclare la variable I (incrément)
Dim J As Byte 'déclare la variable J (incrément)
Dim L As Byte 'déclare la variable L (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau de Lignes)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Set CD = ThisWorkbook 'définit le classeur destination CD
CH = ThisWorkbook.Path & "\" 'définit le chemin d'accès CH
Set OD = CD.Sheets(1) 'définit l'onglet destination OD, le premier onglet du classeur (à adapter à ton cas)
OD.Range("A1").CurrentRegion.Offset(1, 0).Clear 'efface les anciennes données
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
NF = Dir(CH & "*.xls") 'définit le nom du fichier NF (première fichier du dossier ayant CH comme chemin d'accès)
Do While NF <> "" 'exécute tant qu'il existe des fichiers
    If NF <> "recap.xlsm" Then 'condition 1 : si le nom du fichier n'est pas "recap.xlsm"
        If Right(NF, 4) = ".xls" Then 'condition 2 : si l'extension du fichier est ".xls"
            Erase TL 'efface le tableau de ligne TL
            Application.Workbooks.Open (CH & NF) 'ouvre le fichier NF
            Set CS = ActiveWorkbook 'définit le classeur source CS
            Set OS = CS.Sheets("rapport") 'définit l'onglet source OS
            DL = OS.Cells(Application.Rows.Count, 2).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne 2 (=B) de l'onglet OS
            TC = OS.Range("B8:G" & DL) 'définit le tableau de cellules TC (on part de la ligne 8 et jusqu'à la colonne G pas J !)
            K = 1 'initialise la variable K
            For I = 1 To UBound(TC, 1) 'boucle 1 : sur toutes les lignes I du tableau de cellules TC
                For J = 1 To UBound(TC, 2) 'boucle 2 : sur toutes les colonnes J du tableau de cellules TC
                    If TC(I, J) <> "" Then 'condition 'si la valeur en ligne I, colonne J de TC n'est pas vide
                        ReDim Preserve TL(1 To 6, 1 To K) 'redimensionne le tableau TL (6 lignes, K colonnes)
                        For L = 1 To 6 'boucle 3 : sur les 6 colonnes de la ligne
                            TL(L, K) = TC(I, L) 'récupère dans la ligne L de TL la valeur de la colonne L de TC (Transposition)
                        Next L 'prochaine colonne de la boucle 3
                        K = K + 1 'incrémente K (ajoute une colonne à TL)
                        Exit For 'sort de la boucle2
                    End If 'fin de la condition
                Next J 'prochaine colonne de la boucle 2
            Next I 'prochaine ligne de la boucle 1
            If K = 1 Then GoTo suite 'si K=1 => aucune ligne trouvé, passe au fichier suivant via l'étiquette "suite"
            If K = 2 Then ReDim Preserve TL(1 To UBound(TL, 1), 1 To 2) 'si K=2, une seule ligne trouvée, redimensionne TL pour transposer
            'définit la cellue de destination DEST (A1, si A1 est vide, sinon la première cellule vide de la colonne A de l'onglert OD)
            Set DEST = OD.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0)
            DEST.Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL) 'transpose le tableau TL dans DEST redimensionnée
            'ligne se séparation
            OD.Cells(Application.Rows.Count, 1).End(xlUp).Resize(1, 6).Borders(xlEdgeBottom).LineStyle = xlContinuous
suite:     'étiquette
            CS.Close SaveChanges:=False 'ferme le classeur source CS sans enregister
        End If 'fin de la condition 2
    End If 'fin de la condition 1
    NF = Dir 'définit le nom du fichier NF (fichier suivant du dossier ayant CH comme chemin d'accès )
Loop 'boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Transfert des données terminé !" 'message de fin
End Sub

Sinon, comme d'hab., il faut que tu envoies le fichier qui plante pour que je puisse comprendre...

Le 08/04/2015 à 16:03

Je regrette cela ne marche toujours pas, est ce que on ne peut pas scinder en 2 la macro,

une qui récupère toutes les infos et qui tire un trait horizontal après chaque fichier exploré
une qui quand on clique dessus supprime toutes les lignes vides.

Merci pour tes efforts

Le 08/04/2015 à 16:22