-
Edité par Néophyte_VB 14 août 2018 à 9:30:51

Salut,

Pour poster du code utilise le bouton </> au dessus de l'éditeur de texte.

Qu'est-ce qui fait que tu n'arrives pas à adapter le code à ton besoin ? Des morceaux du code que tu ne comprends pas ?

Merci pour l'info concernant le bouton </>

C'est le code ci-dessous que je voudrait remplacer par la routine décrite dans ma demande...

        For I = 1 To UBound(Tbl)
            Set Classeur = Workbooks.Open(Chemin & Tbl(I))
            With Classeur.Worksheets(1):
            Set Cel = .Cells(.Rows.Count, 19).End(xlUp): End With 'sur colonne S
            J = J + 1
            ThisWorkbook.Worksheets("Feuil1").Cells(J, 1).Value = Cel.Value
            Classeur.Close False

Mais,je ne sais quoi écrire 

Voici la description de la  routine

Est-ce que tu comprends ce que fais ce code ligne par ligne ?

Pour l'instant on va se concentrer sur la copie de AH5 dans le fichier cible, pour les autres ce sera globalement du copier-coller de ce qu'on aura fait.

Merci pour le support. Je comprend un peu ce code :  C'est une boucle qui exécute une série de recopie de données d'un fichier vers un autre. On commence sur la ligne 1 jusqu'à la dernière ligne dans la colonne 19, 

Ok pour se concentrer sur la copie de AH5

Je remets la boucle un peu mieux indentée et avec des commentaires sur chaque ligne :

For I = 1 To UBound(Tbl) ' Boucle sur tous les fichiers du tableau
    Set Classeur = Workbooks.Open(Chemin & Tbl(I)) ' Ouverture du fichier donné par Tbl(I)
    With Classeur.Worksheets(1) ' Travail sur la première feuille du fichier ouvert _
                                 '(tu pourras regarder ce que ça fait exactement mais en gros ça permet de raccourcir le code, _
                                 'le .Cells() dans le bloc With revient à écrire Classeur.Worksheets(1).Cells()
        Set Cel = .Cells(.Rows.Count, 19).End(xlUp) ' La dernière cellule remplie de la colonne 19 est enregistrée dans la variable Cel
    End With 
    J = J + 1 ' Incrément de la variable permettant de savoir à quelle ligne enregistrer dans le tableau final
    ThisWorkbook.Worksheets("Feuil1").Cells(J, 1).Value = Cel.Value ' Dans la colonne 1 et ligne J du tableau final, la valeur de Cel est enregistrée
    Classeur.Close False ' Fermeture du fichier sans sauvegarder
Next I

A partir de ça tu n'as que 2 lignes à modifier pour copier la valeur de la cellule AH5 du fichier ouvert en cellule An du fichier final.

-
Edité par Stormweaker 16 août 2018 à 9:43:25

Merci...pour le moment, je n*ne vois que la modification ci-dessous :

Set Cel = .Cells(5, 34)  ' Cellule AH5 à la place de Set Cel = .Cells(.Rows.Count, 19).End(xlUp) 

Je vais tenter et voir ce que cela donner. si cela marche je dupliquer et renomme la variable

Je te tiens au courant

-
Edité par Néophyte_VB 16 août 2018 à 16:05:48

Oui c'est bien ça.

Je te laisse faire pour les autres valeurs à copier du coup.

le traitement unitaire (sur la cellule test) fonctionne bien.

J'ai dupliqué cela et adapté, mais là, j'ai 1 pb : une erreur 'Objet requis' sans plus d'indication 

Sub Test()
   Dim Classeur As Workbook
    Dim Cel As Range
    Dim Tbl() As String
    Dim Chemin As String
    Dim I As Integer
    Dim J As Integer
    Chemin = "C:\Users\7276835D\Downloads\CarnetDeSanté\" '<-- adapter le nom du dossier, doit exister !
    'appel de la fonction...
    Tbl() = RecupFichiers(Chemin)
    'si le tableau a été initialisé...
    If Not Not Tbl Then
        Application.ScreenUpdating = False
        'ouvre les classeurs et récupère les valeurs de la dernière cellule en colonne S de la feuille ayant l'index 1
        'puis referme les classeurs
        'les valeurs sont inscrites en colonne A de la feuille "Feuil1" du classeur contenant la macro
        'les unes au dessous des autres
        For I = 1 To UBound(Tbl)
            Set Classeur = Workbooks.Open(Chemin & Tbl(I)): With Classeur.Worksheets("RAPPORT"): Set CelAH5 = .Cells(5, 34): End With 'sur colonne AH5
            Set Classeur = Workbooks.Open(Chemin & Tbl(I)): With Classeur.Worksheets("RAPPORT"): Set CelAH6 = .Cells(6, 34): End With 'sur colonne AH6
            Set Classeur = Workbooks.Open(Chemin & Tbl(I)): With Classeur.Worksheets("RAPPORT"): Set CelAH7 = .Cells(7, 34): End With 'sur colonne AH7
            Set Classeur = Workbooks.Open(Chemin & Tbl(I)): With Classeur.Worksheets("RAPPORT"): Set CelC66 = .Cells(6, 34): End With 'sur colonne C66
            Set Classeur = Workbooks.Open(Chemin & Tbl(I)): With Classeur.Worksheets("RAPPORT"): Set CelC66 = .Cells(3, 66): End With 'sur colonne C66
            Set Classeur = Workbooks.Open(Chemin & Tbl(I)): With Classeur.Worksheets("RAPPORT"): Set CelC68 = .Cells(3, 68): End With 'sur colonne C68
            Set Classeur = Workbooks.Open(Chemin & Tbl(I)): With Classeur.Worksheets("RAPPORT"): Set CelC69 = .Cells(3, 69): End With 'sur colonne C69
            Set Classeur = Workbooks.Open(Chemin & Tbl(I)): With Classeur.Worksheets("RAPPORT"): Set CelC72 = .Cells(3, 72): End With 'sur colonne C72
            Set Classeur = Workbooks.Open(Chemin & Tbl(I)): With Classeur.Worksheets("RAPPORT"): Set CelC73 = .Cells(3, 73): End With 'sur colonne C73
            Set Classeur = Workbooks.Open(Chemin & Tbl(I)): With Classeur.Worksheets("RAPPORT"): Set CelC74 = .Cells(3, 74): End With 'sur colonne C74
            Set Classeur = Workbooks.Open(Chemin & Tbl(I)): With Classeur.Worksheets("RAPPORT"): Set CelC76 = .Cells(3, 76): End With 'sur colonne C76
            Set Classeur = Workbooks.Open(Chemin & Tbl(I)): With Classeur.Worksheets("RAPPORT"): Set CelC77 = .Cells(3, 77): End With 'sur colonne C77
            Set Classeur = Workbooks.Open(Chemin & Tbl(I)): With Classeur.Worksheets("RAPPORT"): Set CelC78 = .Cells(3, 78): End With 'sur colonne C78
            J = J + 1
            ThisWorkbook.Worksheets("Feuil1").Cells(J, 1).Value = CelAH5.Value
            ThisWorkbook.Worksheets("Feuil1").Cells(J, 2).Value = CelAH6.Value
            ThisWorkbook.Worksheets("Feuil1").Cells(J, 3).Value = CelAH7.Value
            ThisWorkbook.Worksheets("Feuil1").Cells(J, 4).Value = CelC66.Value
            ThisWorkbook.Worksheets("Feuil1").Cells(J, 5).Value = CelC66.Value
            ThisWorkbook.Worksheets("Feuil1").Cells(J, 6).Value = CelC68.Value
            ThisWorkbook.Worksheets("Feuil1").Cells(J, 7).Value = CelC69.Value
            ThisWorkbook.Worksheets("Feuil1").Cells(J, 8).Value = CelC72.Value
            ThisWorkbook.Worksheets("Feuil1").Cells(J, 9).Value = CelC73.Value
            ThisWorkbook.Worksheets("Feuil1").Cells(J, 10).Value = CelC74.Value
            ThisWorkbook.Worksheets("Feuil1").Cells(J, 11).Value = CelC76.Value
            ThisWorkbook.Worksheets("Feuil1").Cells(J, 12).Value = CelC77.Value
            Classeur.Close False
        Next I
        Application.ScreenUpdating = True
    End If
End Sub
Function RecupFichiers(Chemin As String) As String()
    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer
    Fichier = Dir(Chemin & "*.xls*")
    Do While (Len(Fichier) > 0)
        I = I + 1
        ReDim Preserve TableauFichiers(1 To I)
        TableauFichiers(I) = Fichier
        Fichier = Dir()
    Loop
    RecupFichiers = TableauFichiers()
End Function

-
Edité par Néophyte_VB 17 août 2018 à 10:02:30

Quelques corrections à faire :

- Tu n'as besoin d'ouvrir le fichier qu'une seule fois par boucle, là tu l'ouvres de nouveau pour chaque cellule que tu veux;

- Pareil pour le bloc With ... End With : mets toutes les lignes correspondantes dans le même bloc plutôt que d'ouvrir / fermer le même bloc With à chaque fois, tu peux aussi mettre un bloc With sur l'écriture dans le fichier de résultats avec un With ThisWorkbook.Worksheets("Feuil1"), ça sera plus joli;

- Tu as inverser les lignes et les colonnes dans les .Cells pour les cellules de la colonne C;

- Il y a deux fois un Set CelC66 mais pas avec les même coordonnées, et tu l'écris deux fois dans deux colonnes différentes dans la feuille de résultats.

-
Edité par Stormweaker 17 août 2018 à 10:40:17

Merci infiniment, je viens de modifier le traitement. 

Il s'execute bien , mais me génère un msg d'erreur "L'indice  n'appartient pas à la sélection". C'est la fin de la boucle.

Comment puis-je neutrailier ce message  ?

Sub Test()
   Dim Classeur As Workbook
    Dim Cel As Range
    Dim Tbl() As String
    Dim Chemin As String
    Dim I As Integer
    Dim J As Integer
    Chemin = "C:\Users\7276835D\Downloads\CarnetDeSanté\" '<-- adapter le nom du dossier, doit exister !
    'appel de la fonction...
    Tbl() = RecupFichiers(Chemin)
    'si le tableau a été initialisé...
    If Not Not Tbl Then
        Application.ScreenUpdating = False
        'ouvre les classeurs et récupère les valeurs de la dernière cellule en colonne S de la feuille ayant l'index 1
        'puis referme les classeurs
        'les valeurs sont inscrites en colonne A de la feuille "Feuil1" du classeur contenant la macro
        'les unes au dessous des autres
        For I = 1 To UBound(Tbl)
            Set Classeur = Workbooks.Open(Chemin & Tbl(I)):
            With Classeur.Worksheets("RAPPORT"):
                Set CelAH5 = .Cells(5, 34): 'sur colonne AH5
                Set CelAH6 = .Cells(6, 34): 'sur colonne AH6
                Set CelAH7 = .Cells(7, 34): 'sur colonne AH7
                Set CelC66 = .Cells(6, 34): 'sur colonne C66
                Set CelC66 = .Cells(66, 3): 'sur colonne C66
                Set CelC68 = .Cells(68, 3): 'sur colonne C68
                Set CelC69 = .Cells(69, 3): 'sur colonne C69
                Set CelC72 = .Cells(72, 3): 'sur colonne C72
                Set CelC73 = .Cells(73, 3): 'sur colonne C73
                Set CelC74 = .Cells(74, 3): 'sur colonne C74
                Set CelC76 = .Cells(76, 3): 'sur colonne C76
                Set CelC77 = .Cells(77, 3): 'sur colonne C77
                Set CelC78 = .Cells(78, 3): 'sur colonne C78
            End With
            J = J + 1
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 1).Value = CelAH5.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 2).Value = CelAH6.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 3).Value = CelAH7.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 4).Value = CelC66.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 5).Value = CelC66.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 6).Value = CelC68.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 7).Value = CelC69.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 8).Value = CelC72.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 9).Value = CelC73.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 10).Value = CelC74.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 11).Value = CelC76.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 12).Value = CelC77.Value
            Classeur.Close False
        Next I
        Application.ScreenUpdating = True
    End If
End Sub
Function RecupFichiers(Chemin As String) As String()
    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer
    Fichier = Dir(Chemin & "*.xls*")
    Do While (Len(Fichier) > 0)
        I = I + 1
        ReDim Preserve TableauFichiers(1 To I)
        TableauFichiers(I) = Fichier
        Fichier = Dir()
    Loop
    RecupFichiers = TableauFichiers()
End Function

Tu n'as pas besoin de laisser les ':', ils servent à écrire plusieurs instructions sur la même ligne.

Pas d'erreur chez moi.

Est-ce que les onglets "RAPPORT" et "Feuil1" existent dans les classeurs respectifs ?

-
Edité par Stormweaker 20 août 2018 à 12:07:23

J'ai supprimé les ':'

Le traitement fait son job, mais me renvoie le même msg d'erreur. je ne vais pas m'attarder dessus. on verra plus tard 

Dans un post précédent, tu disais qu'il y a deux fois un Set CelC66 dans le code. En fait, c'est fait exprès. c’était réservé une traitement plus complexe sur lequel je travaille 

il s'agit de verifier si U5:AA66, un cellule est renseignée. Si c'est la cas, on récypère la valeur de la cellule positionnée  juste au-dessous. 

C'est un peu galère...mais je cherche 

Merci pour ton aide précieuse

Utilise le débogueur pour voir exactement à quelle instruction le code plante, ça permettra de résoudre le problème.

rebonjour

Après plusieurs de recherches infructueuses, je me permets de poser un dernière question concernant le Set CelC66 que j'avais mis de coté. 

En fait, je n'arrive pas à intégrer  la fonction donc j'ai besoin. 

1.On part d'un tableau allant de U65:AA66

2.On vérifie si la cellule du bas (U66 par exemple) est vide 

  - Si OUI, on ne fait rien 

  - Si NON, on recopie la valeur de la cellue supérieur (U65)

3.Ainsi de suite pour les autres cellules U65:AA66

4.Ensuite, on concatène toutes les cellules U66:AA66 (dans une variable) qu'on recopie dans dans la colonne E de mon fichier cible 

Ci-dessous le code, je ne sais pas ce qui ne va pas 

Sub Test()
    On Error Resume Next
    Dim Classeur As Workbook
    Dim Cel As Range
    Dim Tbl() As String
    Dim Chemin As String
    Dim I As Integer
    Dim J As Integer
    Chemin = "C:\Users\7276835D\Downloads\CarnetDeSanté\" '<-- adapter le nom du dossier, doit exister !
    'appel de la fonction...
    Tbl() = RecupFichiers(Chemin)
    'si le tableau a été initialisé...
    If Not Not Tbl Then
        Application.ScreenUpdating = False
        'ouvre les classeurs et récupère les valeurs de la dernière cellule en colonne S de la feuille ayant l'index 1
        'puis referme les classeurs
        'les valeurs sont inscrites en colonne A de la feuille "Feuil1" du classeur contenant la macro
        'les unes au dessous des autres
        For I = 1 To UBound(Tbl)
            Set Classeur = Workbooks.Open(Chemin & Tbl(I))
            With Classeur.Worksheets("RAPPORT"):
            Set Cel = .Cells(5, 34): End With  'sur colonne AH5
            J = J + 1
            ThisWorkbook.Worksheets("Feuil1").Cells(J, 1).Value = Cel.Value
            MsgBox Cel.Value
            Classeur.Close False
        Next I
        Application.ScreenUpdating = True
    End If
End Sub
Function RecupFichiers(Chemin As String) As String()
    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer
    Fichier = Dir(Chemin & "*.xls*")
    Do While (Len(Fichier) > 0)
        I = I + 1
        ReDim Preserve TableauFichiers(1 To I)
        TableauFichiers(I) = Fichier
        Fichier = Dir()
    Loop
    RecupFichiers = TableauFichiers()
End Function

-
Edité par Néophyte_VB 23 août 2018 à 14:07:46

-
Edité par Stormweaker 23 août 2018 à 14:24:04

Sub test()
   Dim Classeur As Workbook
    Dim Cel As Range
    Dim Tbl() As String
    Dim Chemin As String
    Dim I As Integer
    Dim J As Integer
    Chemin = "C:\Users\7276835D\Downloads\CarnetDeSanté\" '<-- adapter le nom du dossier, doit exister !
    'appel de la fonction...
    Tbl() = RecupFichiers(Chemin)
    'si le tableau a été initialisé...
    If Not Not Tbl Then
        Application.ScreenUpdating = False
        'ouvre les classeurs et récupère les valeurs de la dernière cellule en colonne S de la feuille ayant l'index 1
        'puis referme les classeurs
        'les valeurs sont inscrites en colonne A de la feuille "Feuil1" du classeur contenant la macro
        'les unes au dessous des autres
        For I = 1 To UBound(Tbl)
            Set Classeur = Workbooks.Open(Chemin & Tbl(I)):
            With Classeur.Worksheets("RAPPORT"):
                Set CelAH5 = .Cells(5, 34): 'sur colonne AH5
                Set CelAH6 = .Cells(6, 34): 'sur colonne AH6
                Set CelAH7 = .Cells(7, 34): 'sur colonne AH7
                Set CelC66 = .Cells(6, 34): 'sur colonne C66
                Set CelC66 = .Cells(66, 3): 'sur colonne C66   'decode
                Set CelC68 = .Cells(68, 3): 'sur colonne C68
                Set CelC69 = .Cells(69, 3): 'sur colonne C69
                Set CelC72 = .Cells(72, 3): 'sur colonne C72
                Set CelC73 = .Cells(73, 3): 'sur colonne C73
                Set CelC74 = .Cells(74, 3): 'sur colonne C74
                Set CelC76 = .Cells(76, 3): 'sur colonne C76
                Set CelC77 = .Cells(77, 3): 'sur colonne C77
                Set CelC78 = .Cells(78, 3): 'sur colonne C78
           
                If Len(Trim(ThisWorkbook.Sheets(1).Cells(66, 21))) < 1 Then ThisWorkbook.Sheets(1).Cells(66, 21) = ThisWorkbook.Sheets(1).Cells(65, 21).Value
                If Len(Trim(ThisWorkbook.Sheets(1).Cells(66, 23))) < 1 Then ThisWorkbook.Sheets(1).Cells(66, 23) = ThisWorkbook.Sheets(1).Cells(65, 23).Value
                If Len(Trim(ThisWorkbook.Sheets(1).Cells(66, 24))) < 1 Then ThisWorkbook.Sheets(1).Cells(66, 24) = ThisWorkbook.Sheets(1).Cells(65, 24).Value
                If Len(Trim(ThisWorkbook.Sheets(1).Cells(66, 25))) < 1 Then ThisWorkbook.Sheets(1).Cells(66, 25) = ThisWorkbook.Sheets(1).Cells(65, 25).Value
                If Len(Trim(ThisWorkbook.Sheets(1).Cells(66, 26))) < 1 Then ThisWorkbook.Sheets(1).Cells(66, 26) = ThisWorkbook.Sheets(1).Cells(65, 26).Value
                If Len(Trim(ThisWorkbook.Sheets(1).Cells(66, 27))) < 1 Then ThisWorkbook.Sheets(1).Cells(66, 27) = ThisWorkbook.Sheets(1).Cells(65, 27).Value
                DECODE = Trim(ThisWorkbook.Sheets(1).Cells(66, 21) & ThisWorkbook.Sheets(1).Cells(66, 23) & ThisWorkbook.Sheets(1).Cells(66, 24) & ThisWorkbook.Sheets(1).Cells(66, 25) & ThisWorkbook.Sheets(1).Cells(66, 26) & ThisWorkbook.Sheets(1).Cells(66, 27))
   
              End With
            J = J + 1
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 1).Value = CelAH5.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 2).Value = CelAH6.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 3).Value = CelAH7.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 4).Value = CelC66.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 5) = DECODE
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 6).Value = CelC68.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 7).Value = CelC69.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 8).Value = CelC72.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 9).Value = CelC73.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 10).Value = CelC74.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 11).Value = CelC76.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 12).Value = CelC77.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 14).Value = Classeur.Name 'Nom du fichier traité
            Classeur.Close False
        Next I
        Application.ScreenUpdating = True
    End If
End Sub
Function RecupFichiers(Chemin As String) As String()
    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer
    Fichier = Dir(Chemin & "*.xls*")
    Do While (Len(Fichier) > 0)
        I = I + 1
        ReDim Preserve TableauFichiers(1 To I)
        TableauFichiers(I) = Fichier
        Fichier = Dir()
    Loop
    RecupFichiers = TableauFichiers()
End Function

Pourquoi ce code ne te convient pas ?

Aussi il fait l'inverse de ce que tu m'as dit : il fait la recopie lorsque la cellule est vide.

En tout cas je vais reprendre ton algo en te donnant quelques pistes pour que le code soit plus lisible et moins répétitif.

> 1.On part d'un tableau allant de U65:AA66

Déclare plutôt une Range sur U66:AA66 (pas besoin de la ligne 65, tu verras pourquoi après).

Fais une boucle sur les cellules de cette plage (un For Each convient très bien).

>2.On vérifie si la cellule du bas (U66 par exemple) est vide 

>   - Si NON, on recopie la valeur de la cellue supérieur (U65)

Tu n'es pas obligé d'utiliser Len(cell.value) < 1 pour tester si la cellule est vide, tu peux plus simplement faire cell.value = "".

Pour accéder à la valeur de la cellule du dessus (on travaille sur les cellules de la ligne 66 dans cette boucle) tu peux faire cell.Offset(-1,0).value.

>3.Ainsi de suite pour les autres cellules U65:AA66

La boucle s'en charge.

>4.Ensuite, on concatène toutes les cellules U66:AA66 (dans une variable) qu'on recopie dans dans la colonne E de mon fichier cible

Autant faire ça dans la boucle, juste après le test pour savoir si la cellule est vide.

Houla !  Je suis épaté...Merci pour les bonnes pratiques...

J'ai modifié le code, mais je me rends compte que les valeurs renseignée de U66:AA66 ne sont pas mis à jour

Sub test()
   Dim Classeur As Workbook
    Dim Cel As Range
    Dim Tbl() As String
    Dim Chemin As String
    Dim I As Integer
    Dim J As Integer
    Chemin = "C:\Users\7276835D\Downloads\CarnetDeSanté\" '<-- adapter le nom du dossier, doit exister !
    'appel de la fonction...
    Tbl() = RecupFichiers(Chemin)
    'si le tableau a été initialisé...
    If Not Not Tbl Then
        Application.ScreenUpdating = False
        'ouvre les classeurs et récupère les valeurs de la dernière cellule en colonne S de la feuille ayant l'index 1
        'puis referme les classeurs
        'les valeurs sont inscrites en colonne A de la feuille "Feuil1" du classeur contenant la macro
        'les unes au dessous des autres
        For I = 1 To UBound(Tbl)
            Set Classeur = Workbooks.Open(Chemin & Tbl(I)):
            With Classeur.Worksheets("RAPPORT"):
                Set CelAH5 = .Cells(5, 34): 'sur colonne AH5
                Set CelAH6 = .Cells(6, 34): 'sur colonne AH6
                Set CelAH7 = .Cells(7, 34): 'sur colonne AH7
                Set CelC66 = .Cells(6, 34): 'sur colonne C66
                Set CelC66 = .Cells(66, 3): 'sur colonne C66   'decode
                Set CelC68 = .Cells(68, 3): 'sur colonne C68
                Set CelC69 = .Cells(69, 3): 'sur colonne C69
                Set CelC72 = .Cells(72, 3): 'sur colonne C72
                Set CelC73 = .Cells(73, 3): 'sur colonne C73
                Set CelC74 = .Cells(74, 3): 'sur colonne C74
                Set CelC76 = .Cells(76, 3): 'sur colonne C76
                Set CelC77 = .Cells(77, 3): 'sur colonne C77
                Set CelC78 = .Cells(78, 3): 'sur colonne C78
            
				For Each rCellule In Range("U66:AA66")
				If Resultat = Not IsEmpty(rCellule.Value) Then rCellule = rCellule.Offset(-1, 0).Value 'Valeur trouvée
				Next
				DECODE = Trim(ThisWorkbook.Sheets(1).Cells(66, 21) & ThisWorkbook.Sheets(1).Cells(66, 23) & ThisWorkbook.Sheets(1).Cells(66, 24) & ThisWorkbook.Sheets(1).Cells(66, 25) & ThisWorkbook.Sheets(1).Cells(66, 26) & ThisWorkbook.Sheets(1).Cells(66, 27))
		'		MsgBox (DECODE)
				
              End With
            J = J + 1
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 1).Value = CelAH5.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 2).Value = CelAH6.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 3).Value = CelAH7.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 4).Value = CelC66.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 5) = DECODE
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 6).Value = CelC68.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 7).Value = CelC69.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 8).Value = CelC72.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 9).Value = CelC73.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 10).Value = CelC74.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 11).Value = CelC76.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 12).Value = CelC77.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 14).Value = Classeur.Name 'Nom du fichier traité
            Classeur.Close False
        Next I
        Application.ScreenUpdating = True
    End If
End Sub
Function RecupFichiers(Chemin As String) As String()
    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer
    Fichier = Dir(Chemin & "*.xls*")
    Do While (Len(Fichier) > 0)
        I = I + 1
        ReDim Preserve TableauFichiers(1 To I)
        TableauFichiers(I) = Fichier
        Fichier = Dir()
    Loop
    RecupFichiers = TableauFichiers()
End Function

Merci 

-
Edité par Néophyte_VB 23 août 2018 à 22:46:41

If Resultat = Not IsEmpty(rCellule.Value)

Là tu compares la valeur de Resultat à la valeur de Not IsEmpty(rCellule.Value) qui renvoie true ou false, j'ai aucune idée de ce que peut valoir Resultat, en tout cas t'as pas besoin de récupérer la valeur de Not IsEmpty() dans une variable pour la tester, ou alors il faut le faire en dehors du If car les opérateurs d'affectation et d'égalité sont les même en VBA.

Mets la concaténation de DECODE dans la boucle.

DECODE = DECODE & rCellule.Value

Bonjour 

Après plusieurs essais, je n'arrive pas à récupérer la valeur produite pour la variable "DECODE" dans la colonne E de mon fichier cible 

sais-tu pourquoi ? 

Voici le code entier 

Sub test()
   Dim Classeur As Workbook
    Dim Cel As Range
    Dim Tbl() As String
    Dim Chemin As String
    Dim I As Integer
    Dim J As Integer
    Chemin = "C:\Users\7276835D\Downloads\CarnetDeSanté\" '<-- adapter le nom du dossier, doit exister !
    'appel de la fonction...
    Tbl() = RecupFichiers(Chemin)
    'si le tableau a été initialisé...
    If Not Not Tbl Then
        Application.ScreenUpdating = False
        'ouvre les classeurs et récupère les valeurs de la dernière cellule en colonne S de la feuille ayant l'index 1
        'puis referme les classeurs
        'les valeurs sont inscrites en colonne A de la feuille "Feuil1" du classeur contenant la macro
        'les unes au dessous des autres
        For I = 1 To UBound(Tbl)
            Set Classeur = Workbooks.Open(Chemin & Tbl(I)):
            With Classeur.Worksheets("RAPPORT"):
                Set CelAH5 = .Cells(5, 34): 'sur colonne AH5
                Set CelAH6 = .Cells(6, 34): 'sur colonne AH6
                Set CelAH7 = .Cells(7, 34): 'sur colonne AH7
                Set CelC66 = .Cells(6, 34): 'sur colonne C66
                Set CelC66 = .Cells(66, 3): 'sur colonne C66   'decode
                Set CelC68 = .Cells(68, 3): 'sur colonne C68
                Set CelC69 = .Cells(69, 3): 'sur colonne C69
                Set CelC72 = .Cells(72, 3): 'sur colonne C72
                Set CelC73 = .Cells(73, 3): 'sur colonne C73
                Set CelC74 = .Cells(74, 3): 'sur colonne C74
                Set CelC76 = .Cells(76, 3): 'sur colonne C76
                Set CelC77 = .Cells(77, 3): 'sur colonne C77
                Set CelC78 = .Cells(78, 3): 'sur colonne C78
             
                For Each rCellule In Range("U66:AA66")
                    If rCellule.Value <> "" Then rCellule = rCellule.Offset(-1, 0).Value 'Valeur trouvée
                    'MsgBox (rCellule & rCellule.Value & rCellule.Offset(-1, 0))
                    'If Not IsEmpty(rCellule.Value) Then rCellule = rCellule.Offset(-1, 0).Value 'Valeur trouvée
                    DECODE = DECODE & rCellule.Value
                Next
                'DECODE = Trim(ThisWorkbook.Sheets(1).Cells(66, 21) & ThisWorkbook.Sheets(1).Cells(66, 23) & ThisWorkbook.Sheets(1).Cells(66, 24) & ThisWorkbook.Sheets(1).Cells(66, 25) & ThisWorkbook.Sheets(1).Cells(66, 26) & ThisWorkbook.Sheets(1).Cells(66, 27))
                'MsgBox (DECODE)
                 
              End With
            J = J + 1
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 1).Value = CelAH5.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 2).Value = CelAH6.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 3).Value = CelAH7.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 4).Value = CelC66.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 5) = DECODE
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 6).Value = CelC68.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 7).Value = CelC69.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 8).Value = CelC72.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 9).Value = CelC73.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 10).Value = CelC74.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 11).Value = CelC76.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 12).Value = CelC77.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 14).Value = Classeur.Name 'Nom du fichier traité
            Classeur.Close False
        Next I
        Application.ScreenUpdating = True
    End If
End Sub
Function RecupFichiers(Chemin As String) As String()
    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer
    Fichier = Dir(Chemin & "*.xls*")
    Do While (Len(Fichier) > 0)
        I = I + 1
        ReDim Preserve TableauFichiers(1 To I)
        TableauFichiers(I) = Fichier
        Fichier = Dir()
    Loop
    RecupFichiers = TableauFichiers()
End Function

-
Edité par Néophyte_VB 29 août 2018 à 13:22:44

Lignes 36 et 50 : Utilise .Value quand tu veux modifier la valeur d'une cellule plutôt que ne rien mettre, ça revient au même mais c'est plus explicite et ce sera homogène avec le reste du code.

Il n'y a que l'écriture de DECODE en colonne E qui pose problème ? Le reste fonctionne ? Est-ce que tu as regardé si DECODE est non vide ?

Aussi tu devrais mettre .Range ligne 35, sinon c'est pas clair quelle feuille de quel classeur est utilisée pour la plage U66:AA66.

Bonjour

J'ai modifié le code conformément à ce que tu m'as dit. Il fonctionne correctement à l'exception de l'écriture de DECODE en colonne E. 

Lorsque je lance les MsgBox sur rCellule.Value & rCellule.Offset(-1, 0).Value, la popup est vide

Sub test()
   Dim Classeur As Workbook
    Dim Cel As Range
    Dim Tbl() As String
    Dim Chemin As String
    Dim I As Integer
    Dim J As Integer
    Chemin = "C:\Users\7276835D\Downloads\CarnetDeSanté\" '<-- adapter le nom du dossier, doit exister !
    'appel de la fonction...
    Tbl() = RecupFichiers(Chemin)
    'si le tableau a été initialisé...
    If Not Not Tbl Then
        Application.ScreenUpdating = False
        'ouvre les classeurs et récupère les valeurs de la dernière cellule en colonne S de la feuille ayant l'index 1
        'puis referme les classeurs
        'les valeurs sont inscrites en colonne A de la feuille "Feuil1" du classeur contenant la macro
        'les unes au dessous des autres
        For I = 1 To UBound(Tbl)
            Set Classeur = Workbooks.Open(Chemin & Tbl(I)):
            With Classeur.Worksheets("RAPPORT"):
                Set CelAH5 = .Cells(5, 34): 'sur colonne AH5
                Set CelAH6 = .Cells(6, 34): 'sur colonne AH6
                Set CelAH7 = .Cells(7, 34): 'sur colonne AH7
                Set CelC66 = .Cells(6, 34): 'sur colonne C66
                Set CelC66 = .Cells(66, 3): 'sur colonne C66   'decode
                Set CelC68 = .Cells(68, 3): 'sur colonne C68
                Set CelC69 = .Cells(69, 3): 'sur colonne C69
                Set CelC72 = .Cells(72, 3): 'sur colonne C72
                Set CelC73 = .Cells(73, 3): 'sur colonne C73
                Set CelC74 = .Cells(74, 3): 'sur colonne C74
                Set CelC76 = .Cells(76, 3): 'sur colonne C76
                Set CelC77 = .Cells(77, 3): 'sur colonne C77
                Set CelC78 = .Cells(78, 3): 'sur colonne C78
             
                For Each rCellule In Range("U66:AA66")
                    If rCellule.Value <> "" Then rCellule = rCellule.Offset(-1, 0).Value 'Valeur trouvée
                    'MsgBox (rCellule & rCellule.Value & rCellule.Offset(-1, 0))
                'If Not IsEmpty(rCellule.Value) Then rCellule = rCellule.Offset(-1, 0).Value 'Valeur trouvée
                    DECODE = DECODE & rCellule.Value
                Next
                'DECODE = Trim(ThisWorkbook.Sheets(1).Cells(66, 21) & ThisWorkbook.Sheets(1).Cells(66, 23) & ThisWorkbook.Sheets(1).Cells(66, 24) & ThisWorkbook.Sheets(1).Cells(66, 25) & ThisWorkbook.Sheets(1).Cells(66, 26) & ThisWorkbook.Sheets(1).Cells(66, 27))
                'MsgBox (DECODE)
                 
              End With
            J = J + 1
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 1).Value = CelAH5.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 2).Value = CelAH6.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 3).Value = CelAH7.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 4).Value = CelC66.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 5) = DECODE
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 6).Value = CelC68.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 7).Value = CelC69.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 8).Value = CelC72.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 9).Value = CelC73.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 10).Value = CelC74.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 11).Value = CelC76.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 12).Value = CelC77.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 14).Value = Classeur.Name 'Nom du fichier traité
            Classeur.Close False
        Next I
        Application.ScreenUpdating = True
    End If
End Sub
Function RecupFichiers(Chemin As String) As String()
    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer
    Fichier = Dir(Chemin & "*.xls*")
    Do While (Len(Fichier) > 0)
        I = I + 1
        ReDim Preserve TableauFichiers(1 To I)
        TableauFichiers(I) = Fichier
        Fichier = Dir()
    Loop
    RecupFichiers = TableauFichiers()
End Function

-
Edité par Stormweaker 30 août 2018 à 9:58:43

Désolé...je suis un peu perdu avec mes différents copie/coller

Voici le nouveau code qui a fonctionne. 

J'ai dû remplacer If rCellule.Value <> ""  par If rCellule.Value = "X"  Les cellules vides ne semblent pas NULL

Merci encore pour ton coaching 

Sub test()
   Dim Classeur As Workbook
    Dim Cel As Range
    Dim Tbl() As String
    Dim Chemin As String
    Dim I As Integer
    Dim J As Integer
    Chemin = "C:\Users\7276835D\Downloads\CarnetDeSanté\" '<-- adapter le nom du dossier, doit exister !
    'appel de la fonction...
    Tbl() = RecupFichiers(Chemin)
    'si le tableau a été initialisé...
    If Not Not Tbl Then
        Application.ScreenUpdating = False
        'ouvre les classeurs et récupère les valeurs de la dernière cellule en colonne S de la feuille ayant l'index 1
        'puis referme les classeurs
        'les valeurs sont inscrites en colonne A de la feuille "Feuil1" du classeur contenant la macro
        'les unes au dessous des autres
        For I = 1 To UBound(Tbl)
            Set Classeur = Workbooks.Open(Chemin & Tbl(I)):
            With Classeur.Worksheets("RAPPORT"):
                Set CelAH5 = .Cells(5, 34): 'sur colonne AH5
                Set CelAH6 = .Cells(6, 34): 'sur colonne AH6
                Set CelAH7 = .Cells(7, 34): 'sur colonne AH7
                Set CelC66 = .Cells(6, 34): 'sur colonne C66
                Set CelC66 = .Cells(66, 3): 'sur colonne C66   'decode
                Set CelC68 = .Cells(68, 3): 'sur colonne C68
                Set CelC69 = .Cells(69, 3): 'sur colonne C69
                Set CelC72 = .Cells(72, 3): 'sur colonne C72
                Set CelC73 = .Cells(73, 3): 'sur colonne C73
                Set CelC74 = .Cells(74, 3): 'sur colonne C74
                Set CelC76 = .Cells(76, 3): 'sur colonne C76
                Set CelC77 = .Cells(77, 3): 'sur colonne C77
                Set CelC78 = .Cells(78, 3): 'sur colonne C78
              
                For Each rCellule In .Range("U66:AA66")
                    If rCellule.Value = "X" Then rCellule.Value = rCellule.Offset(-1, 0).Value 'Valeur trouvée
                    'MsgBox (rCellule & rCellule.Value & rCellule.Offset(-1, 0))
                'If Not IsEmpty(rCellule.Value) Then rCellule = rCellule.Offset(-1, 0).Value 'Valeur trouvée
                    DECODE = DECODE & rCellule.Value
                Next
                'DECODE = Trim(ThisWorkbook.Sheets(1).Cells(66, 21) & ThisWorkbook.Sheets(1).Cells(66, 23) & ThisWorkbook.Sheets(1).Cells(66, 24) & ThisWorkbook.Sheets(1).Cells(66, 25) & ThisWorkbook.Sheets(1).Cells(66, 26) & ThisWorkbook.Sheets(1).Cells(66, 27))
                'MsgBox (DECODE)
                  
              End With
            J = J + 1
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 1).Value = CelAH5.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 2).Value = CelAH6.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 3).Value = CelAH7.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 4).Value = CelC66.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 5).Value = DECODE
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 6).Value = CelC68.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 7).Value = CelC69.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 8).Value = CelC72.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 9).Value = CelC73.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 10).Value = CelC74.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 11).Value = CelC76.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 12).Value = CelC77.Value
                ThisWorkbook.Worksheets("Feuil1").Cells(J, 14).Value = Classeur.Name 'Nom du fichier traité
            Classeur.Close False
        Next I
        Application.ScreenUpdating = True
    End If
End Sub
Function RecupFichiers(Chemin As String) As String()
    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer
    Fichier = Dir(Chemin & "*.xls*")
    Do While (Len(Fichier) > 0)
        I = I + 1
        ReDim Preserve TableauFichiers(1 To I)
        TableauFichiers(I) = Fichier
        Fichier = Dir()
    Loop
    RecupFichiers = TableauFichiers()
End Function

Donc tout fonctionne maintenant ?

Et oui si il y a des espaces ou autres caractères "invisibles" dans les cellules le test <> "" ne fonctionne pas.

Tout fonctionne !!!

Merci encore à toi