Consolider VBA - fichiers non trouves

Le 29/09/2017 à 19:25

Bonjour j'ai un soucis sur ma macro vba consolider : J'ai 2 fichiers de synthèse que je veux regrouper en un seul au travers d'une macro vba "consolider". Mais après avoir fonctionné une fois, celle-ci me dit maintenant qu'elle ne trouve pas les fichiers à consolider lors de l’exécution. Pourriez-vous m'aider s'il vous plait.

l'ensemble de mes 3 fichiers sont dans le même dossier (mais je ne pense pas que cela vienne de là).

Merci à vous pour vos éclaircissement.

Synthèse globale : Synthèse arbitrage 2018

Fichiers à consolider : SyntArbitre2018 - SyntArbitre2017

Quand il y a le blocage, quand je passe la souris sur la ligne "nomClasseur" le classeur s'affiche.

Macro :

Option Explicit

'Déclaration variables

Dim NomClasseur As String

Dim LigneTotal As Integer

Dim Derligne As Integer

'Procedure permettant de consolider classeurs

Sub Consolider()

'on désactive le raffressichement de l'écran

Application.ScreenUpdating = False

'Etape 1 Création des en-têtes

'On réinitialise le fichier synthèse

Columns("B:S").Clear

Range("A1").Value = "N°"

Range("B1").Value = "NOM"

Range("C1").Value = "PRENOM"

Range("D1").Value = "NAISSANCE"

Range("E1").Value = "ADRESSE"

Range("F1").Value = "CP"

Range("G1").Value = "VILLE"

Range("H1").Value = "COURRIEL"

Range("I1").Value = "TEL FIXE"

Range("J1").Value = "TEL PORT"

Range("K1").Value = "CLUB"

Range("L1").Value = "LICENCE"

Range("M1").Value = "ANNEE DEB"

Range("N1").Value = "NIV 2017"

Range("O1").Value = "DDE 2018"

Range("P1").Value = "ARBITRE 2018"

Range("Q1").Value = "AP 2017"

Range("R1").Value = "AP 2018"

Range("S1").Value = "ANC LIGUE"

'Couleur de fond

Range("A1:S1").Interior.Color = vbBlue

'Couleur de police

Range("A1:S1").Font.Color = vbWhite

'Mise en gras

Range("A1:S1").Font.Bold = True

'Etape 2 : Parcourir les deux fichiers

ChDir "G:\TRIATHLON\Arbitrage\2018\3_Formation\Fiche_retour_2018\Synthèses"

'On cherche le premier classeur dans le dossier

NomClasseur = Dir("G:\TRIATHLON\Arbitrage\2018\3_Formation\Fiche_retour_2018\Synthèses\*.xlsx")

'On boucle

While Len(NomClasseur) > 0

Application.DisplayAlerts = False 'Désactive boite de dialogue

Workbooks.Open NomClasseur 'Ouverture du classeur

LigneTotal = ActiveSheet.UsedRange.Rows.Count 'On compte le nb de ligne

Range("B4:S" & LigneTotal).Copy 'On copie ttes les lignes

Workbooks("Synthèse arbitrage 2018").Activate 'On revient sur la synthèse

Derligne = ActiveSheet.UsedRange.Rows.Count + 1 'On recherche la plage vide

Range("B" & Derligne).Select 'On se positionne sur la dernière ligne vide

ActiveSheet.Paste 'Je colle les données

Workbooks(NomClasseur).Close 'Fermeture classeur ouvert

NomClasseur = Dir 'On passe au prochain classeur

Range("A1").Select

Wend

MsgBox "La consolidation est terminée."

'on réactive le raffressichement de l'écran

Application.ScreenUpdating = True

End Sub

13synthese-arbitrage-2018.xlsm (23.82 Ko)
11syntarbitre2017.xlsx (40.06 Ko)
12syntarbitre2018.xlsx (104.40 Ko)
Le 30/09/2017 à 07:58

Bonjour

Il y a peut-être un problème avec les adresses des fichiers.

Mais puisque tu écris :

l'ensemble de mes 3 fichiers sont dans le même dossier

Pourquoi ne pas en profiter et s'affranchir des adresses :

voir ci-joint :

Bye !

24militaire.zip (163.42 Ko)
Le 30/09/2017 à 09:55

Bonjour,

Une approche sensiblement pareille mais avec quelques différences tout de même. J'utilise une fonction pour retourner les chemins et noms des différents classeur car ça clarifie le code et ensuite, je préfère l'affectation des valeurs plutôt que des copier/coller et pour finir, j'utilise une variable objet (Classeur) afin de bien différencier les deux classeurs ouverts :

'Procedure permettant de consolider classeurs
Sub Consolider()

Dim Tbl
Dim Classeur As Workbook
Dim TblFichiers() As String
Dim Chemin As String
Dim I As Long
Dim LigneTotal As Integer
Dim Derligne As Integer

'on désactive le raffressichement de l'écran
Application.ScreenUpdating = False

ThisWorkbook.ActiveSheet.UsedRange.Clear

'On réinitialise le fichier synthèse :

'Etape 1 Création des en-têtes
Tbl = Array("N°", "NOM", "PRENOM", "NAISSANCE", "ADRESSE", "CP", "VILLE", "COURRIEL", "TEL FIXE", "TEL PORT", "CLUB", _
            "LICENCE", "ANNEE DEB", "NIV 2017", "DDE 2018", "ARBITRE 2018", "AP 2017", "AP 2018", "ANC LIGUE")

With Range(Cells(1, 1), Cells(1, UBound(Tbl) + 1))

    .Value = Tbl
    .Interior.Color = vbBlue 'Couleur de fond
    .Font.Color = vbWhite 'Couleur de police
    .Font.Bold = True 'Mise en gras

End With

'Etape 2 : récupérer les valeurs des fichiers
Chemin = "G:\TRIATHLON\Arbitrage\2018\3_Formation\Fiche_retour_2018\Synthèses"

'utilise une fonction qui retourne un tableau de noms de fichiers
TblFichiers = RecupFichiers(Chemin, ".xlsx")

For I = 1 To UBound(TblFichiers)

    Application.DisplayAlerts = False
    Set Classeur = Workbooks.Open(TblFichiers(I)) 'Ouverture du classeur

    'les feuilles des différents classeurs où sont récupéré les valeurs doivent être nommées "Synthèse" (ce qui est le cas dans les deux fichiers exemple)
    LigneTotal = Classeur.Worksheets("Synthèse").UsedRange.Rows.Count 'On compte le nb de ligne
    Derligne = ThisWorkbook.ActiveSheet.UsedRange.Rows.Count + 1 'On recherche la plage vide

    With ThisWorkbook.ActiveSheet

        .Range(.Cells(Derligne, 2), .Cells(Derligne + LigneTotal - 4, .UsedRange.Columns.Count)).Value = _
        Classeur.Worksheets("Synthèse").Range("B4:S" & LigneTotal).Value

    End With

    Workbooks(Dir(TblFichiers(I))).Close False  'Fermeture classeur ouvert

Next I

MsgBox "La consolidation est terminée."

Application.ScreenUpdating = True

End Sub

Function RecupFichiers(Chemin As String, Extension As String) As String()

    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer

    If Left(Extension, 1) <> "." Then Extension = "." & Extension
    If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"

    Fichier = Dir(Chemin & "*" & Extension)

    Do While (Len(Fichier) > 0)

        I = I + 1

        ReDim Preserve TableauFichiers(1 To I)

        TableauFichiers(I) = Chemin & Fichier

        Fichier = Dir()

    Loop

    RecupFichiers = TableauFichiers()

End Function
Le 30/09/2017 à 12:38

Merci à vous deux, c'est vraiment très sympa de m'avoir aidé.

Je suis super content.

Est ce que l'un de vous aurait un petit fichier VBA à ajouter à ma macro afin de mettre un compteur dans ma ligne N° afin de me mettre le nombre d'arbitre automatiquement, en sachant qu'il va avoir au fur et à mesure de nouveaux noms.

Encore merci à vous deux.

Le 30/09/2017 à 16:00

Re,

Je te re-poste juste la proc "Consolider" avec la numérotation de 1 à x en colonne A :

'Procedure permettant de consolider classeurs
Sub Consolider()

    Dim Tbl
    Dim Classeur As Workbook
    Dim TblFichiers() As String
    Dim Chemin As String
    Dim I As Long
    Dim LigneTotal As Integer
    Dim Derligne As Integer

    'on désactive le raffressichement de l'écran
    Application.ScreenUpdating = False

    ThisWorkbook.ActiveSheet.UsedRange.Clear

    'On réinitialise le fichier synthèse :

    'Etape 1 Création des en-têtes
    Tbl = Array("N°", "NOM", "PRENOM", "NAISSANCE", "ADRESSE", "CP", "VILLE", "COURRIEL", "TEL FIXE", "TEL PORT", "CLUB", _
                "LICENCE", "ANNEE DEB", "NIV 2017", "DDE 2018", "ARBITRE 2018", "AP 2017", "AP 2018", "ANC LIGUE")

    With Range(Cells(1, 1), Cells(1, UBound(Tbl) + 1))

        .Value = Tbl
        .Interior.Color = vbBlue 'Couleur de fond
       .Font.Color = vbWhite 'Couleur de police
       .Font.Bold = True 'Mise en gras

    End With

    'Etape 2 : récupérer les valeurs des fichiers
    Chemin = "E:\Téléchargements\Test" '"G:\TRIATHLON\Arbitrage\2018\3_Formation\Fiche_retour_2018\Synthèses"

    'utilise une fonction qui retourne un tableau de noms de fichiers
    TblFichiers = RecupFichiers(Chemin, ".xlsx")

    For I = 1 To UBound(TblFichiers)

        Application.DisplayAlerts = False
        Set Classeur = Workbooks.Open(TblFichiers(I)) 'Ouverture du classeur

        'les feuilles des différents classeurs où sont récupéré les valeurs doivent être nommées "Synthèse" (ce qui est le cas dans les deux fichiers exemple)
       LigneTotal = Classeur.Worksheets("Synthèse").UsedRange.Rows.Count 'On compte le nb de ligne
       Derligne = ThisWorkbook.ActiveSheet.UsedRange.Rows.Count + 1 'On recherche la plage vide

        With ThisWorkbook.ActiveSheet

            .Range(.Cells(Derligne, 2), .Cells(Derligne + LigneTotal - 4, .UsedRange.Columns.Count)).Value = _
            Classeur.Worksheets("Synthèse").Range("B4:S" & LigneTotal).Value

        End With

        Workbooks(Dir(TblFichiers(I))).Close False  'Fermeture classeur ouvert

    Next I

    'numérote de 1 à x en colonne A
    With ThisWorkbook.ActiveSheet

        .Cells(2, 1).Value = 1
        .Cells(3, 1).Value = 2
        .Range(.Cells(2, 1), .Cells(3, 1)).AutoFill .Range(.Cells(2, 1), Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 1))

    End With

    MsgBox "La consolidation est terminée."

    Application.ScreenUpdating = True

End Sub
Le 01/10/2017 à 07:47

Bonjour,

Rectification d'une petite erreur dans le dernier code que j'ai posté, c'est :

Chemin = "G:\TRIATHLON\Arbitrage\2018\3_Formation\Fiche_retour_2018\Synthèses"

au lieu de :

Chemin = "E:\Téléchargements\Test" '"G:\TRIATHLON\Arbitrage\2018\3_Formation\Fiche_retour_2018\Synthèses"

Chemin qui m'a servi pour mes tests !

Le 01/10/2017 à 12:39

Merci à toi Theze.

Le 01/10/2017 à 13:06

Bonjour à toi et merci pour ta réponse, qui marche super bien.

Pourrais-je encore abusé de toi ?

Dans ma synthèse finale, j'ai la liste de tous les arbitres anciens et nouveaux (qui vont arriver petit à petit) et j'aimerai rajouter une condition dans la consolidation pour n'avoir dans la synthèse globale, uniquement ceux qui ont dit "oui" dans la colonne "P" arbitre 2018 ?

Encore merci à toi.

J'essaye de comprendre vba mais si on ne pratique pas régulièrement c'est chaud.

Merci

Le 01/10/2017 à 18:01

Bonjour,

Je te re poste tout le code car j'ai fais quelques modifs et ajouté une Sub (Filtrer) et une Fonction (DefPlage).

Plutôt que de filtrer à chaque import de feuille, je filtre seulement à la fin tous les enregistrements et le résultat du filtrage est collé dans la feuille "Feuil2" puis la feuille "Feuil1" qui a reçu tout les enregistrements est supprimée et la feuille "Feuil2" est renommée en "Consolidation". Si ces deux feuilles n'existe pas, différents messages demandent à ce qu'elles soient ajoutées ou renommées :

'Procedure permettant de consolider classeurs
Sub Consolider()

    Dim Tbl
    Dim Classeur As Workbook
    Dim Fe1 As Worksheet
    Dim Fe2 As Worksheet
    Dim TblFichiers() As String
    Dim Chemin As String
    Dim I As Long
    Dim LigneTotal As Integer
    Dim Derligne As Integer

    'on désactive le raffressichement de l'écran
    Application.ScreenUpdating = False

    'deux feuilles minimum doivent se trouver dans le classeur
    If Worksheets.Count < 2 Then MsgBox "Le classeur doit comporter au moins deux feuilles !": Exit Sub

    'contrôle si il y a une feuille qui s'appelle "Feuil1"...
    On Error Resume Next
    Set Fe1 = ThisWorkbook.Worksheets("Feuil1")

    'si ce n'est pas le cas, renomme la feuille active en "Feuil1"
    If Err.Number <> 0 Then MsgBox "Une feuille dans le classeur doit s'appeler 'Feuil1'": Exit Sub

    Set Fe2 = ThisWorkbook.Worksheets("Feuil2")

    'si ce n'est pas le cas, renomme la feuille active en "Feuil1"
    If Err.Number <> 0 Then MsgBox "Une feuille dans le classeur s'appelle 'Feuil1' mais une autre doit s'appeler 'Feuil2'": Exit Sub

    On Error GoTo 0

    Fe1.UsedRange.Clear
    Fe2.UsedRange.Clear

    'On réinitialise le fichier synthèse :

    'Etape 1 Création des en-têtes
    Tbl = Array("N°", "NOM", "PRENOM", "NAISSANCE", "ADRESSE", "CP", "VILLE", "COURRIEL", "TEL FIXE", "TEL PORT", "CLUB", _
                "LICENCE", "ANNEE DEB", "NIV 2017", "DDE 2018", "ARBITRE 2018", "AP 2017", "AP 2018", "ANC LIGUE")

    With Fe1.Range(Cells(1, 1), Cells(1, UBound(Tbl) + 1))

        .Value = Tbl
        .Interior.Color = vbBlue 'Couleur de fond
        .Font.Color = vbWhite 'Couleur de police
        .Font.Bold = True 'Mise en gras

    End With

    'Etape 2 : récupérer les valeurs des fichiers
    Chemin = "G:\TRIATHLON\Arbitrage\2018\3_Formation\Fiche_retour_2018\Synthèses"

    'utilise une fonction qui retourne un tableau de noms de fichiers
    TblFichiers = RecupFichiers(Chemin, ".xlsx")

    'gestion de l'absence de fichier dans le dossier ou de mauvais chemin
    On Error GoTo Fin
    For I = 1 To UBound(TblFichiers)

        Application.DisplayAlerts = False
        Set Classeur = Workbooks.Open(TblFichiers(I)) 'Ouverture du classeur

        'les feuilles des différents classeurs où sont récupéré les valeurs doivent être nommées "Synthèse" (ce qui est le cas dans les deux fichiers exemple)
        LigneTotal = Classeur.Worksheets("Synthèse").UsedRange.Rows.Count 'On compte le nb de ligne
        Derligne = Fe1.UsedRange.Rows.Count + 1 'On recherche la plage vide

        With Fe1

            .Range(.Cells(Derligne, 2), .Cells(Derligne + LigneTotal - 4, .UsedRange.Columns.Count)).Value = _
            Classeur.Worksheets("Synthèse").Range("B4:S" & LigneTotal).Value

        End With

        Workbooks(Dir(TblFichiers(I))).Close False  'Fermeture classeur ouvert

    Next I

    'filtre la feuille et copie le résultat sur la feuille "Feuil2"...
    Filtrer Fe1, Fe2, 18, "oui"

    'puis supprime la feuille "Feuil1"
    Application.DisplayAlerts = False
    Fe1.Delete
    Application.DisplayAlerts = True

    'renomme la feuille
    Fe2.Name = "Consolidation"

    'numérote de 1 à x en colonne A
    With Fe2

        .Cells(2, 1).Value = 1
        .Cells(3, 1).Value = 2
        .Range(.Cells(2, 1), .Cells(3, 1)).AutoFill .Range(.Cells(2, 1), Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 1))

    End With

    MsgBox "La consolidation est terminée."

    Application.ScreenUpdating = True

    Exit Sub

Fin:
    MsgBox "Aucun fichier dans le dossier :" & _
           vbCrLf & _
           Chemin & _
           vbCrLf & vbCrLf & _
           "Vérifiez la présence des fichiers dans le dossier !", vbExclamation

End Sub

Function RecupFichiers(Chemin As String, Extension As String) As String()

    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer

    If Left(Extension, 1) <> "." Then Extension = "." & Extension
    If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"

    Fichier = Dir(Chemin & "*" & Extension)

    Do While (Len(Fichier) > 0)

        I = I + 1

        ReDim Preserve TableauFichiers(1 To I)

        TableauFichiers(I) = Chemin & Fichier

        Fichier = Dir()

    Loop

    RecupFichiers = TableauFichiers()

End Function

Sub Filtrer(Fe1 As Worksheet, Fe2 As Worksheet, NumChamp As Integer, Critere As String)

    Dim Plage As Range

    With Fe1

        Set Plage = DefPlage(Fe1)

        Plage.AutoFilter NumChamp, Critere

        .AutoFilter.Range.EntireRow.Copy Fe2.Range("A1")

    End With

    Plage.AutoFilter

End Sub

Function DefPlage(Fe As Worksheet, Optional L As Long = 1, Optional C As Long = 1) As Range

    On Error GoTo Fin

    With Fe

        Set DefPlage = .Range(.Cells(L, C), _
                       .Cells(.Cells.Find("*", .[A1], -4123, , _
                       1, 2).Row, .Cells.Find("*", .[A1], -4123, , _
                       2, 2).Column))

    End With

    Exit Function

Fin:

    Set DefPlage = Nothing

End Function
Le 01/10/2017 à 20:06

Merci à toi. C'est super sympa et cela fonctionne super bien. J'ai juste changé le numéro de la colonne à "filtrer". C'était sur la 16 au lieu de la 18.

Encore merci.

Le 01/10/2017 à 20:19

Re,

Content de t'avoir aidé

Rechercher des sujets similaires à "consolider vba fichiers trouves"