Code VBA - Consolider
Résolu
xavier62000
Messages postés
78
Date d'inscription
Statut
Membre
Dernière intervention
-
xavier62000 Messages postés 78 Date d'inscription Statut Membre Dernière intervention -
xavier62000 Messages postés 78 Date d'inscription Statut Membre Dernière intervention -
Bonsoir, et merci d'avance
Trouvez ci-dessous, un code VBA pour consolider des données de différents classeurs en un seul.
J'ai fait des Tests, et ce code fonctionne mais j'ai apparemment 2 soucis :
le 1° problème : Il faut obligatoirement que je puisse sélectionner la feuille de calcul "JOUEURS" dans ce code c'est la page active soit ActiveSheet. Dans mon cas mes classeurs ont plusieurs feuille de calcul
le 2° problème : j'aimerais copier les valeurs et la forme etc... (surtout pas les formules) sinon j'aurai des #REF# partout
Aussi, je vous demande si vous pouviez m'apporter les corrections pour remédier à ma problématique.
Pour améliorer mon test est-il possible de supprimer les lignes dont les cellules dans la colonne "F" sont vides
Lien de téléchargement :
Code VBA pour consolider appuyer sur le bouton : https://mon-partage.fr/f/1ek3ddK6/
2 fichiers test : https://mon-partage.fr/f/ufyW1NiS/
https://mon-partage.fr/f/HuEEfZn4/
Sinon :
Option Explicit
' Déclaration de variables
Dim Nomclasseur As String
Dim LigneTotal As Integer
Dim Derligne As Integer
'Procédure permettant la consolidation de plusieurs classeurs
Sub consolider()
'on désactive le raffraichissement de l'écran
Application.ScreenUpdating = False
' Etape n°1 : création des en-têtes
'Réinitialisation du fichier de synthèse des classements
Columns("B:AK").Clear
Range("B2").Value = "Equipe N°"
Range("C2").Value = "Joueurs N°"
Range("D2").Value = "Equipe"
Range("E2").Value = "Licence"
Range("F2").Value = "Nom Prénom"
Range("G2").Value = "Nom"
Range("H2").Value = "Prénom"
Range("I2").Value = "Points aller"
Range("J2").Value = "Points Gagnés"
Range("K2").Value = "Points Perdus"
Range("L2").Value = "Total des Points"
Range("M2").Value = "Evolution Clt"
Range("O2").Value = "Points Retour"
Range("P2").Value = "Points Gagnés 2"
Range("Q2").Value = "Points Perdus 3"
Range("R2").Value = " Total des Points 4"
Range("S2").Value = " Evolution Clt 5"
Range("T2").Value = "1"
Range("U2").Value = "2"
Range("V2").Value = "3"
Range("W2").Value = "4"
Range("X2").Value = "5"
Range("Y2").Value = "6"
Range("Z2").Value = "7"
Range("AA2").Value = "8"
Range("AB2").Value = "9"
Range("AC2").Value = "10"
Range("AD2").Value = "11"
Range("AE2").Value = "12"
Range("AF2").Value = "13"
Range("AG2").Value = "14"
Range("AH2").Value = "15"
Range("AI2").Value = "16"
Range("AJ2").Value = "17"
Range("AK2").Value = "18"
'Etape n° 2 : Parcourir tous les fichiers du dossier prédéfini
ChDir "C:\Users\Godin Xavier\Documents\Xavier\Tennis de table\2018-2019\Classements_UFOLEP"
' on cherche le premier classeur dans le dossier
Nomclasseur = Dir("C:\Users\Godin Xavier\Documents\Xavier\Tennis de table\2018-2019\Classements_UFOLEP\*.xlsx")
' on boucle pour chercher tous les classeurs
While Len(Nomclasseur) > 0
Application.DisplayAlerts = False 'Désactive les boites de dialogue d'Excel
Workbooks.Open Nomclasseur 'Ouverture du Classeur'
'Worksheets ("JOUEURS") 'Je sélectionne la feuille de calcul JOUEURS "
LigneTotal = ActiveSheet.UsedRange.Rows.Count 'on récupère le nombre de lignes de données
Range("B3:AK" & LigneTotal).Copy 'on copie toutes les données de la feuille de données
Workbooks("consolidation des classements.xlsm").Activate
'Worksheets ("JOUEURS") 'Je sélectionne la feuille de calcul JOUEURS "
Derligne = ActiveSheet.UsedRange.Rows.Count + 1 'on recherche la dernière ligne vide de la feuille active
Range("B" & Derligne).Select ' on se positionne sur la dernière ligne vide de la feuille active
ActiveSheet.Paste ' Je colle les données
Workbooks(Nomclasseur).Close ' Fermeture du classeur ouvert
Nomclasseur = Dir 'on passe au prochain classeur
Wend
MsgBox " Importation terminée "
'on ré-active le raffraichissement de l'écran '
Application.ScreenUpdating = True
End Sub
Merci d'avance
Trouvez ci-dessous, un code VBA pour consolider des données de différents classeurs en un seul.
J'ai fait des Tests, et ce code fonctionne mais j'ai apparemment 2 soucis :
le 1° problème : Il faut obligatoirement que je puisse sélectionner la feuille de calcul "JOUEURS" dans ce code c'est la page active soit ActiveSheet. Dans mon cas mes classeurs ont plusieurs feuille de calcul
le 2° problème : j'aimerais copier les valeurs et la forme etc... (surtout pas les formules) sinon j'aurai des #REF# partout
Aussi, je vous demande si vous pouviez m'apporter les corrections pour remédier à ma problématique.
Pour améliorer mon test est-il possible de supprimer les lignes dont les cellules dans la colonne "F" sont vides
Lien de téléchargement :
Code VBA pour consolider appuyer sur le bouton : https://mon-partage.fr/f/1ek3ddK6/
2 fichiers test : https://mon-partage.fr/f/ufyW1NiS/
https://mon-partage.fr/f/HuEEfZn4/
Sinon :
Option Explicit
' Déclaration de variables
Dim Nomclasseur As String
Dim LigneTotal As Integer
Dim Derligne As Integer
'Procédure permettant la consolidation de plusieurs classeurs
Sub consolider()
'on désactive le raffraichissement de l'écran
Application.ScreenUpdating = False
' Etape n°1 : création des en-têtes
'Réinitialisation du fichier de synthèse des classements
Columns("B:AK").Clear
Range("B2").Value = "Equipe N°"
Range("C2").Value = "Joueurs N°"
Range("D2").Value = "Equipe"
Range("E2").Value = "Licence"
Range("F2").Value = "Nom Prénom"
Range("G2").Value = "Nom"
Range("H2").Value = "Prénom"
Range("I2").Value = "Points aller"
Range("J2").Value = "Points Gagnés"
Range("K2").Value = "Points Perdus"
Range("L2").Value = "Total des Points"
Range("M2").Value = "Evolution Clt"
Range("O2").Value = "Points Retour"
Range("P2").Value = "Points Gagnés 2"
Range("Q2").Value = "Points Perdus 3"
Range("R2").Value = " Total des Points 4"
Range("S2").Value = " Evolution Clt 5"
Range("T2").Value = "1"
Range("U2").Value = "2"
Range("V2").Value = "3"
Range("W2").Value = "4"
Range("X2").Value = "5"
Range("Y2").Value = "6"
Range("Z2").Value = "7"
Range("AA2").Value = "8"
Range("AB2").Value = "9"
Range("AC2").Value = "10"
Range("AD2").Value = "11"
Range("AE2").Value = "12"
Range("AF2").Value = "13"
Range("AG2").Value = "14"
Range("AH2").Value = "15"
Range("AI2").Value = "16"
Range("AJ2").Value = "17"
Range("AK2").Value = "18"
'Etape n° 2 : Parcourir tous les fichiers du dossier prédéfini
ChDir "C:\Users\Godin Xavier\Documents\Xavier\Tennis de table\2018-2019\Classements_UFOLEP"
' on cherche le premier classeur dans le dossier
Nomclasseur = Dir("C:\Users\Godin Xavier\Documents\Xavier\Tennis de table\2018-2019\Classements_UFOLEP\*.xlsx")
' on boucle pour chercher tous les classeurs
While Len(Nomclasseur) > 0
Application.DisplayAlerts = False 'Désactive les boites de dialogue d'Excel
Workbooks.Open Nomclasseur 'Ouverture du Classeur'
'Worksheets ("JOUEURS") 'Je sélectionne la feuille de calcul JOUEURS "
LigneTotal = ActiveSheet.UsedRange.Rows.Count 'on récupère le nombre de lignes de données
Range("B3:AK" & LigneTotal).Copy 'on copie toutes les données de la feuille de données
Workbooks("consolidation des classements.xlsm").Activate
'Worksheets ("JOUEURS") 'Je sélectionne la feuille de calcul JOUEURS "
Derligne = ActiveSheet.UsedRange.Rows.Count + 1 'on recherche la dernière ligne vide de la feuille active
Range("B" & Derligne).Select ' on se positionne sur la dernière ligne vide de la feuille active
ActiveSheet.Paste ' Je colle les données
Workbooks(Nomclasseur).Close ' Fermeture du classeur ouvert
Nomclasseur = Dir 'on passe au prochain classeur
Wend
MsgBox " Importation terminée "
'on ré-active le raffraichissement de l'écran '
Application.ScreenUpdating = True
End Sub
Merci d'avance
A voir également:
- Code VBA - Consolider
- Code ascii - Guide
- Code puk bloqué - Guide
- Comment déverrouiller un téléphone quand on a oublié le code - Guide
- Code activation windows 10 - Guide
- Scanner qr code pc - Guide
8 réponses
Bonjour,
J'aurais fait comme ça (en mettant tous les fichiers dans le même répertoire, y compris la macro de consolidation) :
Ton fichier en retour :
https://mon-partage.fr/f/p6djCCY9/
J'aurais fait comme ça (en mettant tous les fichiers dans le même répertoire, y compris la macro de consolidation) :
Option Explicit
Sub consolider()
' Procédure permettant la consolidation de plusieurs classeurs
'
Dim wbk As Workbook
Dim wshScr As Worksheet
Dim wshDst As Worksheet
Dim celDst As Range
Dim chemin As String
Dim nomClasseur As String
Dim derLigne As Long
' On désactive le raffraichissement de l'écran
Application.ScreenUpdating = False
' Définition de la feuille de destination
Set wshDst = ThisWorkbook.Worksheets("JOUEURS")
' Etape n°1 : création des en-têtes
'Réinitialisation du fichier de synthèse des classements
With wshDst
.Columns("B:AK").Clear
.Range("B2").Value = "Equipe N°"
.Range("C2").Value = "Joueurs N°"
.Range("D2").Value = "Equipe"
.Range("E2").Value = "Licence"
.Range("F2").Value = "Nom Prénom"
.Range("G2").Value = "Nom"
.Range("H2").Value = "Prénom"
.Range("I2").Value = "Points aller"
.Range("J2").Value = "Points Gagnés"
.Range("K2").Value = "Points Perdus"
.Range("L2").Value = "Total des Points"
.Range("M2").Value = "Evolution Clt"
.Range("O2").Value = "Points Retour"
.Range("P2").Value = "Points Gagnés 2"
.Range("Q2").Value = "Points Perdus 3"
.Range("R2").Value = " Total des Points 4"
.Range("S2").Value = " Evolution Clt 5"
.Range("T2").Value = "1"
.Range("U2").Value = "2"
.Range("V2").Value = "3"
.Range("W2").Value = "4"
.Range("X2").Value = "5"
.Range("Y2").Value = "6"
.Range("Z2").Value = "7"
.Range("AA2").Value = "8"
.Range("AB2").Value = "9"
.Range("AC2").Value = "10"
.Range("AD2").Value = "11"
.Range("AE2").Value = "12"
.Range("AF2").Value = "13"
.Range("AG2").Value = "14"
.Range("AH2").Value = "15"
.Range("AI2").Value = "16"
.Range("AJ2").Value = "17"
.Range("AK2").Value = "18"
' On définit la cellule de destination des données
Set celDst = .Range("B3")
End With
' Etape n° 2 : Parcourir tous les fichiers du dossier prédéfini
chemin = ThisWorkbook.Path & "\"
' On cherche le premier classeur dans le dossier
nomClasseur = Dir(chemin & "*.xlsx")
' On boucle pour chercher tous les classeurs
Do While Len(nomClasseur) > 0
If nomClasseur <> ThisWorkbook.Name Then
Set wbk = Workbooks.Open(chemin & nomClasseur) 'Ouverture du Classeur
On Error Resume Next
Set wshScr = wbk.Worksheets("JOUEURS") 'Définis la feuille de calcul JOUEURS
On Error GoTo 0
If Not wshScr Is Nothing Then
With wshScr
derLigne = .Cells(.Rows.Count, "B").End(xlUp).Row 'Numéro de le derniere ligne de données
Range("B3:AK" & derLigne).Copy celDst 'Copie de toutes les données
End With
' On définit la prochaine cellule de destination des données
Set celDst = celDst.Offset(derLigne - 2)
End If
wbk.Close False ' Fermeture du classeur ouvert sans le modifier
nomClasseur = Dir ' On passe au prochain classeur
End If
Loop
MsgBox " Importation terminée "
' On ré-active le raffraichissement de l'écran '
Application.ScreenUpdating = True
End Sub
Ton fichier en retour :
https://mon-partage.fr/f/p6djCCY9/
Re,
Désolé, une erreur de débutant passée inaperçue car tes fichiers d'essai n'avaient qu'une seule feuille :
J'ai oublié le point devant Range de la ligne 74, c'est donc les données de la feuille active qui étaient copiées au lieu de celles de wshSrc.
Voici ton fichier en retour, avec la suppression des lignes inutiles :
https://mon-partage.fr/f/SpLzVyzF/
Pour ce qui est du total des points, il faudrait le faire sur une autre feuille en ne conservant que les colonnes utiles.
Désolé, une erreur de débutant passée inaperçue car tes fichiers d'essai n'avaient qu'une seule feuille :
J'ai oublié le point devant Range de la ligne 74, c'est donc les données de la feuille active qui étaient copiées au lieu de celles de wshSrc.
Voici ton fichier en retour, avec la suppression des lignes inutiles :
https://mon-partage.fr/f/SpLzVyzF/
Pour ce qui est du total des points, il faudrait le faire sur une autre feuille en ne conservant que les colonnes utiles.
Désolé, encore une erreur de code, au lieu de :
Ecrire :
' Nom du prochain classeur
nomClasseur = Dir
End If
Loop
Ecrire :
End If
' Nom du prochain classeur
nomClasseur = Dir
Loop
Bonjour Patrice,
Merci, pour tes explications, sur le sujet.
Mon fichier en retour est absent.
De plus, il faut savoir que ces fichiers sont partagés avec d'autres utilisateurs dans DROPBOX.
L'inconvénient, dans dropbox c'est que je peux partagés uniquement les dossiers "pour modifications" et par conséquent tous ces fichiers seront dans des répertoires différents. (A ce jour je n'ai pas encore fait les tests.
Peux tu me renvoyé mon fichier.
Bien à Toi
Xavier
Merci, pour tes explications, sur le sujet.
Mon fichier en retour est absent.
De plus, il faut savoir que ces fichiers sont partagés avec d'autres utilisateurs dans DROPBOX.
L'inconvénient, dans dropbox c'est que je peux partagés uniquement les dossiers "pour modifications" et par conséquent tous ces fichiers seront dans des répertoires différents. (A ce jour je n'ai pas encore fait les tests.
Peux tu me renvoyé mon fichier.
Bien à Toi
Xavier
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre question
Re, Patrice
J'ai bien le fichier en retour désolé. Mais celui-ci rencontre des soucis car il ne consolide pas les bonnes feuilles de calcul "JOUEURS". Si tu peux rejeter un oeil, je t'en serai reconnaissant
lien de téléchargement du fichier qui consolide : https://mon-partage.fr/f/FdvnCp6I/
Lien de téléchargement des 2 fichiers à consolider : https://mon-partage.fr/f/gd1Q5LH8/
https://mon-partage.fr/f/yfhfpCz1/
De plus, est il possible dans le fichier "Consolidation des classements" de :
1°) Supprimer les lignes qui se servent à rien (c'est à dire ou il n'y a pas de nom)
2°) D'additionner les points des joeurs dont le numéro de licence est identique (je dois certainement demander la lune mais il y a vraiment des cracs) à défaut, je ferai une autre feuille de calcul.
J'ai bien le fichier en retour désolé. Mais celui-ci rencontre des soucis car il ne consolide pas les bonnes feuilles de calcul "JOUEURS". Si tu peux rejeter un oeil, je t'en serai reconnaissant
lien de téléchargement du fichier qui consolide : https://mon-partage.fr/f/FdvnCp6I/
Lien de téléchargement des 2 fichiers à consolider : https://mon-partage.fr/f/gd1Q5LH8/
https://mon-partage.fr/f/yfhfpCz1/
De plus, est il possible dans le fichier "Consolidation des classements" de :
1°) Supprimer les lignes qui se servent à rien (c'est à dire ou il n'y a pas de nom)
2°) D'additionner les points des joeurs dont le numéro de licence est identique (je dois certainement demander la lune mais il y a vraiment des cracs) à défaut, je ferai une autre feuille de calcul.
Tout d'abord en grand merci,
Pour un débutant qu'est ce que je devrais dire moi : embrillons !!
La personne qui s'occupe des classements au niveau de ma région va etre heureux car avant avec sa feuille calcul je n'ose même pas t expliquer le report d'informations manuelles.
Au vu du fichier en retour, j'ai du modifier qq chose dans le code puisque maintenant l'extension des fichiers à consolider est en xlsm. Comme j'ai des macros avec les modifications apporter par Vaucluse.
Sauf que maintenant ça Bugg bien.
As tu encore un peu temps à m'accorder ?
Liens de téléchargement
https://mon-partage.fr/f/dKAz70kZ/
https://mon-partage.fr/f/GTQuRMdH/
https://mon-partage.fr/f/zhzaELox/
Merci pour ta patience
Pour un débutant qu'est ce que je devrais dire moi : embrillons !!
La personne qui s'occupe des classements au niveau de ma région va etre heureux car avant avec sa feuille calcul je n'ose même pas t expliquer le report d'informations manuelles.
Au vu du fichier en retour, j'ai du modifier qq chose dans le code puisque maintenant l'extension des fichiers à consolider est en xlsm. Comme j'ai des macros avec les modifications apporter par Vaucluse.
Sauf que maintenant ça Bugg bien.
As tu encore un peu temps à m'accorder ?
Liens de téléchargement
https://mon-partage.fr/f/dKAz70kZ/
https://mon-partage.fr/f/GTQuRMdH/
https://mon-partage.fr/f/zhzaELox/
Merci pour ta patience
