Discussion :

[FOB11]

Bonjour,

J'ai un fichier avec pleins de macro VBA pour une priorisation de projets. Suite à une réunion on m'a demandé d'inverser les colonnes avec les lignes de mon tableau EVALUATION.


Y'a-t-il une façon de le faire par macro afin de ne pas retaper tout le code ?

NB : le tableau a des listes déroulantes et des calculs par macro

Je vous joins les codes correspondant à la feuille EVALUATION :

Option Explicit
Option Private Module

Sub MaJ()

With Sheet4 'paramétrage critères de sélection
Dim Col_Od As Integer: Col_Od = .Range("C6").Value 'Ordre
Dim Col_Nm As Integer: Col_Nm = .Range("C7").Value 'Noms des criteres
Dim Col_P1 As Integer: Col_P1 = .Range("C8").Value 'Premiere Colonne des points
Dim Col_Pn As Integer: Col_Pn = .Range("C9").Value 'Derniere Colonne des points
Dim Col_Cf As Integer: Col_Cf = .Range("C10").Value 'Coefficients
Dim Lig_Pr As Integer: Lig_Pr = .Range("C17").Value 'Premiere ligne apres en-tete
End With

With Sheet4 'paramétrage évaluation
Dim Col2_Pr As Integer: Col2_Pr = .Range("F5").Value 'Premiere
Dim Col2_Od As Integer: Col2_Od = .Range("F6").Value 'Ordre
Dim Col2_Nm As Integer: Col2_Nm = .Range("F7").Value 'Noms des criteres
Dim Col2_Cf As Integer: Col2_Cf = .Range("F8").Value 'Coefficients
Dim Col2_P1 As Integer: Col2_P1 = .Range("F9").Value 'Premiere Colonne des projets
Dim Col2_Dr As Integer: Col2_Dr = .Range("F10").Value 'Derniere
Dim Lig2_Pr As Integer: Lig2_Pr = .Range("F17").Value 'Premiere ligne apres en-tete
Dim Nbr2_Pr As Integer: Nbr2_Pr = .Range("L2").Value 'Nombre des projets
End With

Dim I, J, Max As Integer
Dim Nom As String
Dim Nm As Name
Dim RngName As String

RngName = "Priorite"

Alerts False

With Sheet3 'évaluation
.Shapes("Rectangle").Top = 0
.Shapes("Rectangle").Left = 0

Max = .Cells(Lig2_Pr - 1, Columns.Count).End(xlToLeft).Column
'If Max >= Col2_P1 Then .Range(.Cells(Lig2_Pr, Col2_P1), .Cells(Lig2_Pr, Max)).Delete shift:=xlToLeft

' Criteres de sélection
Max = Sheet2.Cells(Rows.Count, Col_Od).End(xlUp).Row

If Max >= Lig_Pr Then
Sheet2.Range(Sheet2.Cells(Lig_Pr, Col_Od), Sheet2.Cells(Max, Col_Od)).Copy
.Cells(Lig2_Pr, Col2_Od).PasteSpecial xlPasteValues
.Cells(Lig2_Pr, Col2_Od).PasteSpecial xlPasteValidation

Sheet2.Range(Sheet2.Cells(Lig_Pr, Col_Nm), Sheet2.Cells(Max, Col_Nm)).Copy
.Cells(Lig2_Pr, Col2_Nm).PasteSpecial xlPasteValues
.Cells(Lig2_Pr, Col2_Nm).PasteSpecial xlPasteValidation

Sheet2.Range(Sheet2.Cells(Lig_Pr, Col_Cf), Sheet2.Cells(Max, Col_Cf)).Copy
.Cells(Lig2_Pr, Col2_Cf).PasteSpecial xlPasteValues
.Cells(Lig2_Pr, Col2_Cf).PasteSpecial xlPasteValidation
End If

' Projets
J = 1
If Nbr2_Pr > 0 Then
For I = Col2_P1 To Col2_P1 + Nbr2_Pr - 1
If .Cells(Lig2_Pr - 1, I).Value = "" Then .Cells(Lig2_Pr - 1, I).Value = "Projet " & J
.Cells(Lig2_Pr - 1, I).WrapText = True
.Cells(Lig2_Pr - 1, I).Orientation = 45
J = J + 1
Next I
End If

' Matrice Validation Data
J = Lig2_Pr
If Nbr2_Pr > 0 And Col_Pn - Col_P1 > 0 Then

For Each Nm In ActiveWorkbook.Names
On Error Resume Next
If Nm.Name <> "Coefficients" And Nm.Name <> "Priorite" Then Nm.Delete
Next Nm

For I = Lig_Pr To Max
Nom = "Noms" & I
Sheet2.Range(Sheet2.Cells(I, Col_P1), Sheet2.Cells(I, Col_Pn)).Name = Nom
Nom = "=" & Nom
.Range(.Cells(J, Col2_P1), .Cells(J, Col2_P1 + Nbr2_Pr - 1)).Validation.Delete
.Range(.Cells(J, Col2_P1), .Cells(J, Col2_P1 + Nbr2_Pr - 1)).Validation.Add _
Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:=Nom
J = J + 1
Next I
End If


Sub MaJTotal()

With Sheet4 'paramétrage critères de sélection
Dim Col_Od As Integer: Col_Od = .Range("C6").Value 'Ordre
Dim Col_Nm As Integer: Col_Nm = .Range("C7").Value 'Noms des criteres
Dim Col_P1 As Integer: Col_P1 = .Range("C8").Value 'Premiere Colonne des points
Dim Col_Pn As Integer: Col_Pn = .Range("C9").Value 'Derniere Colonne des points
Dim Col_Cf As Integer: Col_Cf = .Range("C10").Value 'Coefficients
Dim Lig_Pr As Integer: Lig_Pr = .Range("C17").Value 'Premiere ligne apres en-tete
End With

With Sheet4 'paramétrage évaluation
Dim Col2_Pr As Integer: Col2_Pr = .Range("F5").Value 'Premiere
Dim Col2_Od As Integer: Col2_Od = .Range("F6").Value 'Ordre
Dim Col2_Nm As Integer: Col2_Nm = .Range("F7").Value 'Noms des criteres
Dim Col2_Cf As Integer: Col2_Cf = .Range("F8").Value 'Coefficients
Dim Col2_P1 As Integer: Col2_P1 = .Range("F9").Value 'Premiere Colonne des projets
Dim Col2_Dr As Integer: Col2_Dr = .Range("F10").Value 'Derniere
Dim Lig2_Pr As Integer: Lig2_Pr = .Range("F17").Value 'Premiere ligne apres en-tete
Dim Nbr2_Pr As Integer: Nbr2_Pr = .Range("L2").Value 'Nombre des projets
End With

Dim I, J, Max As Integer
Dim RngName As String
Max = Sheet2.Cells(Rows.Count, Col_Od).End(xlUp).Row

RngName = "Priorite"

Alerts False

With Sheet3 'évaluation
For I = Col2_P1 To Col2_P1 + Nbr2_Pr - 1
.Cells(Lig2_Pr + Max - Lig_Pr + 1, I).Value = TotalPoints(Col2_Cf, .Range(.Cells(Lig2_Pr, I), .Cells(Lig2_Pr + Max - Lig_Pr, I)), Col_P1, Col_Pn)

If .Cells(Lig2_Pr + Max - Lig_Pr + 1, I).Value <> "" Then
For J = 0 To Sheet4.Range(RngName).Count - 1
If CInt(.Cells(Lig2_Pr + Max - Lig_Pr + 1, I).Value) >= CInt(Sheet4.Cells(Sheet4.Range(RngName).Row + J, Sheet4.Range(RngName).Column - 1).Value) And _
CInt(.Cells(Lig2_Pr + Max - Lig_Pr + 1, I).Value) <= CInt(Sheet4.Cells(Sheet4.Range(RngName).Row + J, Sheet4.Range(RngName).Column + 1).Value) Then

.Cells(Lig2_Pr + Max - Lig_Pr + 1, I).Interior.Color = Sheet4.Cells(Sheet4.Range(RngName).Row + J, Sheet4.Range(RngName).Column).Interior.Color
.Cells(Lig2_Pr + Max - Lig_Pr + 2, I).Interior.Color = Sheet4.Cells(Sheet4.Range(RngName).Row + J, Sheet4.Range(RngName).Column).Interior.Color
.Cells(Lig2_Pr + Max - Lig_Pr + 2, I).Value = Sheet4.Cells(Sheet4.Range(RngName).Row + J, Sheet4.Range(RngName).Column).Value
Exit For
End If
Next J
End If
Next I
End With

Alerts True
End Sub