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 CopieVersFeuille(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) 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
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
CopieVersFeuille = 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 InitVariables(W1 As Worksheet, W2 As Worksheet, W3 As Worksheet, _
NumColF1Service As Long, NumColF1Nom As Long, NumColF1Echeance As Long, _
NumColF2Service As Long, NumColF2Nom As Long, NumColF2Echeance As Long, _
NumColF3Service As Long, NumColF3Nom As Long, NumColF3Echeance As Long, _
TitreCol1, TitreCol2, TitreCol3 As String _
)
Set W1 = Worksheets("Feuil1"): Set W2 = Worksheets("Feuil2"): Set W3 = Worksheets("Feuil3")
NumColF1Service = 2: NumColF1Nom = 1: NumColF1Echeance = 3
NumColF2Service = 2: NumColF2Nom = 1: NumColF2Echeance = 3
NumColF3Service = 1: NumColF3Nom = 2: NumColF3Echeance = 3
TitreCol1 = "Service": TitreCol2 = "Nom": TitreCol3 = "Echeance"
End Function
Sub TriPlanning()
'
' TriPlanning Macro
'
' 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
Dim NumColF3Service As Long, NumColF3Nom As Long, NumColF3Echeance As Long
Dim TitreCol1 As String, TitreCol2 As String, TitreCol3 As String
' On initialise les variables (il en manque sûrement).
' Pourquoi diantre faut-il un retour à cette fonction ??
i = InitVariables(W1, W2, W3, _
NumColF1Service, NumColF1Nom, NumColF1Echeance, _
NumColF2Service, NumColF2Nom, NumColF2Echeance, _
NumColF3Service, NumColF3Nom, NumColF3Echeance, _
TitreCol1, TitreCol2, TitreCol3 _
)
' On nettoie la Feuille 3
W3.Cells.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
' -- La copie des données de 1 et 2 vers 3 --
Dim Tab1NbLig As Long ' Nbre de lignes dans feuille 1 : Pour l'offset du deuxième appel à la fonction de copie.
Dim Tab2NbLig As Long ' Nbre de lignes dans feuille 2 : Ne sert à rien mais semble obligatoire pour le retour de la fonction.
Tab1NbLig = CopieVersFeuille(W1, NumColF1Service, NumColF1Nom, NumColF1Echeance, _
W3, NumColF3Service, NumColF3Nom, NumColF3Echeance, 2)
Tab2NbLig = CopieVersFeuille(W2, NumColF2Service, NumColF2Nom, NumColF2Echeance, _
W3, NumColF3Service, NumColF3Nom, NumColF3Echeance, Tab1NbLig + 1)
' -- Le tri des données de 3 -- VA SORTIR EN FONCTION
' Variables pour la partie Tri
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.
Range(CLRange(NumColF3Service, 1, NumColF3Echeance, Tab3NbLig)).Select
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
' Le découpage par mois VA 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 otal de lignes
LigNbTot = W3.Range(CLAlpha(NumColF3Service, Rows.Count)).End(xlUp).Row ' Méthode discutable, je n'ai pas mieux.
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
' Les titres en ligne 2
W3.Cells(2, (ARemplirCol * 3) + 1) = "SERVICE"
W3.Cells(2, (ARemplirCol * 3) + 2) = "NOM"
W3.Cells(2, (ARemplirCol * 3) + 3) = "ECHEANCE"
End If
' On copie les données vers la colonne but
W3.Cells(ARemplirLig, (ARemplirCol * 3) + 1) = W3.Cells(LigCpt, 1)
W3.Cells(ARemplirLig, (ARemplirCol * 3) + 2) = W3.Cells(LigCpt, 2)
W3.Cells(ARemplirLig, (ARemplirCol * 3) + 3) = W3.Cells(LigCpt, 3)
' On met la colonne d'Echeance au format Date
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"
' On passe à la ligne à remplir suivante
ARemplirLig = ARemplirLig + 1
' On passe à la ligne à lire suivante
LigCpt = LigCpt + 1
Wend
' On supprime les trois premières colonnes qui ne servent plus
Columns(LettreNumCol(NumColF3Service) & ":" & LettreNumCol(NumColF3Echeance)).Delete Shift:=xlToLeft
' On centre les deux premières lignes
Rows("1:2").HorizontalAlignment = xlCenter
' On se positionne sur la première cellule
' Range(CLRange(NumColF3Service, 1, NumColF3Service, 1)).Select
Range("A1:A1").Select
' La mise en forme n'est absolument pas faite (cadre, gras, centrage, couleurs ...) C'est faisable.
End Sub