INVERSER les colonnes avec les lignes macro VBA

Nyssa94 Messages postés 1 Date d'inscription jeudi 15 juin 2023 Statut Membre Dernière intervention 15 juin 2023 - 15 juin 2023 à 10:43

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
A voir également: