Code VBA - Consolider Résolu

Question

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

Patrice33740 · Answer

Bonjour,

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/

xavier62000 · Answer

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

xavier62000 · Answer

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.

Patrice33740 · Answer

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.

xavier62000 · Answer

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

Patrice33740 · Answer

Désolé, encore une erreur de code, au lieu de :
      ' Nom du prochain classeur
      nomClasseur = Dir
    End If
  Loop

Ecrire :
    End If
    ' Nom du prochain classeur
    nomClasseur = Dir
  Loop

xavier62000 · Answer

Bonsoir Patrice 

C'est NIckel, super sympa

Je vais voir pour la suite

xavier

xavier62000 · Answer

Bonsoir Patrice, 

Peux tu me savoir quelle fonction que je peux prendre pour arriver à ce résultat 

 https://mon-partage.fr/f/DAzgJehU/

Merci d'avance

Code VBA - Consolider

8 réponses

Discussions similaires

Newsletters