Créer un échéancier en fonction d'un tableau aux informations multiples

  • Auteur de la discussion adelitodelapampa
  • Date de début

svoglimacci

check memory failed but no bug detected
Code:
Option Explicit
Function CLAlpha(Col As Long, Lig As Long) As String
' Transforme N° Colonne et N° Ligne en nom alpha de cellule.
' Exemple : (2, 3) -> "B3"
    CLAlpha = Cells(Lig, Col).Address(RowAbsolute:=False, ColumnAbsolute:=False)
End Function
Function CLRange(Col1 As Long, Lig1 As Long, Col2 As Long, Lig2 As Long) As String
' Transforme Col 1, Lig 1, Col 2, Lig 2 en Range.
' Exemple : (2, 3, 4, 5) -> "B3:D5"
    CLRange = CLAlpha(Col1, Lig1) & ":" & CLAlpha(Col2, Lig2)
End Function
Function LettreNumCol(Col As Long) As String
' Transforme N° Colonne en tettre
' genre 2 -> B ou 27 -> AA
' Cela semble bidouillé mais je n'ai pas mieux. Une fonction purement VBA Excel serait mieux.
    LettreNumCol = Split(Cells(, Col).Address(RowAbsolute:=True, ColumnAbsolute:=False), "$")(0)
End Function
Function PrepareF3(W3 As Worksheet, _
                   NumColF3Service As Long, NumColF3Nom As Long, NumColF3Echeance As Long, _
                   TitreCol1, TitreCol2, TitreCol3 As String _
    )
' Mise en place de la feuille 3
    ' On nettoie la Feuille totalement. Formattage, couleurs --> poubelle
    W3.Cells.Select
    Selection.Clear

' On met les titres dans Feuile 3
' (inutiles, les colonnes vont être supprimées mais en cas de débug...)
    W3.Range(CLAlpha(NumColF3Service, 1)) = TitreCol1
    W3.Range(CLAlpha(NumColF3Nom, 1)) = TitreCol2
    W3.Range(CLAlpha(NumColF3Echeance, 1)) = TitreCol3
End Function
Function CopieVersF3(WOri As Worksheet, _
                           NumColOriService As Long, NumColOriNom As Long, NumColOriEcheance As Long, _
                           WBut As Worksheet, _
                           NumColButService As Long, NumColButNom As Long, NumColButEcheance As Long, _
                           OffsetBut As Long _
  )
' Copie les zones concernées d'une WOri vers une WBut
' Renvoie le nombre de lignes trouvées, on en a en fait besoin pour la deuxième copie.

' On récupère le nombre de lignes de la feuille
    Dim NbLig As Long ' Nom plus court et plus cohérent que le nom de la fonction.
    NbLig = WOri.Range(CLAlpha(NumColOriService, Rows.Count)).End(xlUp).Row
' On met ce nombre de ligne dans la zone de renvoi car l'appelant en aura besoin
    CopieVersF3 = NbLig
' On copie les parties de colonnes de WOri et on les colle dans WBut
    WOri.Range(CLRange(NumColOriService, 2, NumColOriService, NbLig)).Copy
    WBut.Range(CLAlpha(NumColButService, OffsetBut)).PasteSpecial
    WOri.Range(CLRange(NumColOriNom, 2, NumColOriNom, NbLig)).Copy
    WBut.Range(CLAlpha(NumColButNom, OffsetBut)).PasteSpecial
    WOri.Range(CLRange(NumColOriEcheance, 2, NumColOriEcheance, NbLig)).Copy
    WBut.Range(CLAlpha(NumColButEcheance, OffsetBut)).PasteSpecial
End Function
Function TrieLaFeuille3(W3 As Worksheet, NumColF3Service As Long, NumColF3Nom As Long, NumColF3Echeance As Long)
    Dim Tab3NbLig As Long
' On récupère le nombre de lignes dans Feuil3
    Tab3NbLig = W3.Range(CLAlpha(NumColF3Service, Rows.Count)).End(xlUp).Row
' On trie, pas mal de choses à faire.
    W3.Sort.SortFields.Clear
    W3.Sort.SortFields.Add Key:=Range(CLRange(NumColF3Echeance, 2, NumColF3Echeance, Tab3NbLig)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    W3.Sort.SortFields.Add Key:=Range(CLRange(NumColF3Service, 2, NumColF3Service, Tab3NbLig)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    W3.Sort.SortFields.Add Key:=Range(CLRange(NumColF3Nom, 2, NumColF3Nom, Tab3NbLig)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With W3.Sort
        .SetRange Range(CLRange(NumColF3Service, 1, NumColF3Echeance, Tab3NbLig))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Function
Sub TriPlanning()

' TriPlanning Macro

' Attention /!\ On part du principe que dans les feuilles 1 et 2, les données démarrent en ligne 2
' Pour le moment en tous les cas, aucune paramétrabilité n'est prévue pour cela.
' La mise en place n'en serait pas compliquée.

' Déclaration des variables
    ' Les noms de feuilles, numéros de colonnes, qui simplifient la paramétrabilité
    Dim W1 As Worksheet, W2 As Worksheet, W3 As Worksheet
    Dim NumColF1Service As Long, NumColF1Nom As Long, NumColF1Echeance As Long
    Dim NumColF2Service As Long, NumColF2Nom As Long, NumColF2Echeance As Long
    ' Pour la Feuille 3, ça sera 1, 2, 3 mais des variables rendront le code plus lisible
    Dim NumColF3Service As Long, NumColF3Nom As Long, NumColF3Echeance As Long
    Dim TitreCol1 As String, TitreCol2 As String, TitreCol3 As String

' Initialisation des variables
    Set W1 = Worksheets("Toto"): Set W2 = Worksheets("Titi"): Set W3 = Worksheets("Res")
    NumColF1Service = 7: NumColF1Nom = 4: NumColF1Echeance = 1
    NumColF2Service = 5: NumColF2Nom = 8: NumColF2Echeance = 10
    NumColF3Service = 1: NumColF3Nom = 2: NumColF3Echeance = 3 ' Doit rester ainsi. C'est juste pour faciliter la lisibilité.
    TitreCol1 = "Service": TitreCol2 = "Nom": TitreCol3 = "Echeance" ' Doit rester ainsi. C'est juste pour faciliter la lisibilité.
   
' On prépare la feuille 3
Call PrepareF3(W3, NumColF3Service, NumColF3Nom, NumColF3Echeance, TitreCol1, TitreCol2, TitreCol3)

' Copies des données de feuilles 1 et 2 vers la feuille 3
    Dim Tab1NbLig As Long ' Nbre de lignes dans feuille 1 : Pour l'offset du deuxième appel à la fonction de copie.
    Tab1NbLig = CopieVersF3(W1, NumColF1Service, NumColF1Nom, NumColF1Echeance, _
                                  W3, NumColF3Service, NumColF3Nom, NumColF3Echeance, 2)
    Dim Tab2NbLig As Long ' Nbre de lignes dans feuille 2 : Ne sert à rien mais semble obligatoire pour le retour de la fonction.
    Tab2NbLig = CopieVersF3(W2, NumColF2Service, NumColF2Nom, NumColF2Echeance, _
                                  W3, NumColF3Service, NumColF3Nom, NumColF3Echeance, Tab1NbLig + 1)

' On trie les 3 colonnes de la feuille 3
Call TrieLaFeuille3(W3, NumColF3Service, NumColF3Nom, NumColF3Echeance)

' Le découpage par mois devrait sortir en fonction
    Dim LigCpt As Long ' La variable qui va parcourir le tableau
    Dim LigNbTot As Long
    Dim DateTrav As Date
    Dim AnMoisTrav As String
    Dim AnMoisBase As String
    Dim ARemplirCol As Long
    Dim ARemplirLig As Long
' L'idée est de parcourir le tablea, dates étant triées, et de faire des ruptures par An/Mois
' On récupère le nombre total de lignes
    LigNbTot = W3.Range(CLAlpha(NumColF3Service, Rows.Count)).End(xlUp).Row
    LigCpt = 2 ' On commence à la 2ème ligne, la première est celle des titres
    AnMoisBase = "" ' Pour avoir une rupture dès le début
    ARemplirCol = 0 'Pour donnée la 1ère colonne (paquet de 3) à remplir. La première remplie sera la 2
' On parcourt le tableau
    While (LigCpt <= LigNbTot)
        DateTrav = CDate(W3.Cells(LigCpt, LettreNumCol(NumColF3Echeance)))
' On formatte An/mois avec cas spécial pour avoir 0 devant le mois si < 6. Il devrait y avoir une option de formatage de nombres mais je ne trouve pas
        AnMoisTrav = Year(DateTrav) & "/"
        If (Month(DateTrav)) <= 6 Then
            AnMoisTrav = AnMoisTrav & "0" & Month(DateTrav)
        Else
            AnMoisTrav = AnMoisTrav & Month(DateTrav)
        End If
' Examen des ruptures (changement de Année/mois)
        If (AnMoisBase <> AnMoisTrav) Then ' Si rupture
            AnMoisBase = AnMoisTrav ' On prépare la "base" pour détecter la rupture suivante
            ARemplirCol = ARemplirCol + 1 ' On va remplir le paquet de 3 colonnes suivant.
            ARemplirLig = 3 ' On demarre le remplissage des colonnes en ligne 3 (une ligne pour année mois, une ligne pour les titres
            W3.Cells(1, (ARemplirCol * 3) + 1) = AnMoisTrav ' On colle Année/Mois dans la première ligne
' On fusionne les trois colonnes pour la date : Cells(x,y).address permet d'éviter des bidouilles pour avoir les lettres
            W3.Range( _
                Cells(1, (ARemplirCol * 3) + 1).Address(RowAbsolute:=False, ColumnAbsolute:=False), _
                Cells(1, (ARemplirCol * 3) + 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) _
            ).MergeCells = True
' On met la colonne d'Echeance au format Date POUR LE MOMENT C'EST ICI ON LE GARDE POUR LISIBILITE
            W3.Activate
            Columns(LettreNumCol((ARemplirCol * 3) + 3) & ":" & LettreNumCol((ARemplirCol * 3) + 3)).Select
            Range(LettreNumCol((ARemplirCol * 3) + 3) & "2").Activate 'Qu'est-ce que ce fichu "2" vient faire ici ?
            Selection.NumberFormat = "m/d/yyyy"
' Les titres en ligne 2
            W3.Cells(2, (ARemplirCol * 3) + 1) = TitreCol1
            W3.Cells(2, (ARemplirCol * 3) + 2) = TitreCol2
            W3.Cells(2, (ARemplirCol * 3) + 3) = TitreCol3
        End If
' On copie les données vers la colonne but
' Via une boucle simplificatrice qui retrécit le code et donc logiquement dénommée "D'étroit de Magellan" :)
        Dim increment As Integer
        For increment = 1 To 3
            W3.Cells(ARemplirLig, (ARemplirCol * 3) + increment) = W3.Cells(LigCpt, increment)
        Next
' On passe à la ligne à remplir suivante
        ARemplirLig = ARemplirLig + 1
' On passe à la ligne à lire suivante
        LigCpt = LigCpt + 1
    Wend
'ICI, LA VARIABLE ARemplirCol DONNE LE NOMBRE DE COLONNES (de trois sous colonnes) UTILE POUR LES MISES EN FORME NON ?
' LORS DU NETTOYAGE DE F3, IL FAUDRAIT TROUVER UN MOYEN DE TOUT VIRER, FORMATS ET TOUT ET TOUT.
' On supprime les trois premières colonnes qui ne servent plus
    W3.Columns(LettreNumCol(NumColF3Service) & ":" & LettreNumCol(NumColF3Echeance)).Delete Shift:=xlToLeft
' On centre les deux premières lignes
    W3.Rows("1:2").HorizontalAlignment = xlCenter
' On se positionne sur la première cellule
    W3.Range("A1:A1").Select

' La mise en forme n'est absolument pas faite (cadre, gras, centrage, couleurs ...) C'est faisable.
End Sub
 

drul

Obscur pro du hardware
Staff
W3.Cells.Select
Selection.Clear

c'est bien mais ...

W3.Cells..Clear

c'est mieux non ?

Tu entends quoi par "l'objet excel" ???
 

magellan

Modérâleur
Staff
W3.Cells.Select
Selection.Clear

c'est bien mais ...

W3.Cells..Clear

c'est mieux non ?

Tu entends quoi par "l'objet excel" ???
Je pense qu'il cherche à comprendre comment déclarer clairement un objet et comment le manipuler.
 

magellan

Modérâleur
Staff
Sinon +1, vue le couple de lignes, aucun intérêt de faire deux commandes quand une seule fait le job
@svoglimacci l'usage du selection est comme son nom l'indique de nettoyer sur une sélection déterminée. Cela peut faire sens pour virer de la donnée de manière précise... là comme tu apures une intégralité d'informations, autant ne pas présélectionner pour rien.
 

drul

Obscur pro du hardware
Staff
Dans 9 cas sur 10 l'utilisation de select en vba est erronée.
il n'y a que 3 raisons de l'utiliser.
1°) On veut travailler sur une plage définie par l'utilisateur au lancement de la macro.
2°) on veut spécifié une case active en fin de macro.
3°) Celle à laquelle j'ai pas pensé :D
 

svoglimacci

check memory failed but no bug detected
W3.Cells.Clear c'est mieux non ?
J'avais fait un truc du genre et il me laissait le formatage (fusions, format date...). Je me suis donc trompé quelque part. Merci :)
Je pense qu'il cherche à comprendre comment déclarer clairement un objet et comment le manipuler.
Non non. Je cherche le nom de cette arborescence qui démarre à (je ne sais plus) et qui donne les moyens de faire "RacineJeNeSaisPlus.WorkSheet.Column(1).Row(2).Formule..." (exemple bidon). En clair, est-ce que l'Objet "fichier excel" a un nom particulier :) Ou alors il s'appelle "fichier excel" ? Vue la taille de la bibiche, j'ai supposé qu'il avait un petit nom bien à lui. "Ojet Excel" ? Bon, après OSEF, mon sommeil n'en changera pas ! :)
3°) Celle à laquelle j'ai pas pensé :D
Pffff :D
 

magellan

Modérâleur
Staff
Dans 9 cas sur 10 l'utilisation de select en vba est erronée.
il n'y a que 3 raisons de l'utiliser.
1°) On veut travailler sur une plage définie par l'utilisateur au lancement de la macro.
2°) on veut spécifié une case active en fin de macro.
3°) Celle à laquelle j'ai pas pensé :D
Pour la 3 je peux t'en donner quelques unes
- Construire des zones prédéfinies pour réceptionner/lire un jeu de données particulier
- Traiter en "filtre" qu'une partie d'une recherche (par exemple procéder à des traitements sur des lots de données pour ne pas surcharger inutilement, voire pour avoir par exemple une barre de progression dont les utilisateurs sont friands)
- Imposer par le code un ordre de positionnement des zones rafraîchies pour que visuellement on voit où en est le traitement (par exemple "case 1" colorée si traitement 1 fini, puis case 2 , case 3...

La sélection restreinte doit être utilisée intelligemment tu as tout à fait raison: on ne fait pas n'importe quoi à moins de vouloir s'imposer des galères ("zut où est mon ... de pointeur?!"), on ne prend QUE le nécessaire.
 

svoglimacci

check memory failed but no bug detected
Il est mort ? Il aurait "résolu" et j'ai raté le post ?
Bon, tant pis, cela m'aura un peu remis le pied à l'étrier en VBA et surtout appris plein de choses grâce à vous :)
 
Vous devez vous inscrire ou vous connecter pour répondre ici.
Derniers messages publiés
Statistiques globales
Discussions
730 098
Messages
6 717 055
Membres
1 586 282
Dernier membre
Yannick3553
Partager cette page
Haut