Simplification VBA

[Florian53]

Bonsoir à tous,

Je dispose d'un code VBA qui fonctionne mais je pense qu'il peut être simplifier surtout au niveau des RAZ des som , j'ai essayé avec:

For i=1 to 18
som(i)=0
Next i

Mais ça ne fonctionne pas. Voici le code intégral:

Sub SommeReportingQE()
Dim Nlgn As Integer
Dim tabBDD()
Dim wsBDD As Object
Dim wsResult As Object

Dim som1, som2, som3, som4, som5, som6, som7, som8, som9, som10, som11, som12, som13, som14, som15, som16, som17, som18
Dim crit1, crit2, crit3, crit4
Dim cptBDD
Dim i As Integer

Nlgn = ActiveCell.Column

    Set wsBDD = Worksheets("BDD")
    Set wsResult = Worksheets("Feuil1")

   
    With wsBDD
        tabBDD = Range(.Cells(3, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 23))
    End With
   
    With wsResult
   
    som1 = 0
    som2 = 0
    som3 = 0
    som4 = 0
    som5 = 0
    som6 = 0
    som7 = 0
    som8 = 0
    som9 = 0
    som10 = 0
    som11 = 0
    som12 = 0
    som13 = 0
    som14 = 0
    som15 = 0
    som16 = 0
    som17 = 0
    som18 = 0
   
       
        Application.ScreenUpdating = False
   
        crit1 = .Cells(2, 1)
        crit2 = .Cells(1, Nlgn)
        crit3 = .Cells(8, 1)
        crit4 = .Cells(14, 1)
       
        For cptBDD = 1 To UBound(tabBDD, 1)
            If (tabBDD(cptBDD, 23) = crit1) And (tabBDD(cptBDD, 1) = crit2) Then
                som1 = som1 + tabBDD(cptBDD, 11)
                som2 = som2 + tabBDD(cptBDD, 22)
                som3 = som3 + tabBDD(cptBDD, 12)
                som4 = som4 + tabBDD(cptBDD, 14) + tabBDD(cptBDD, 15) + tabBDD(cptBDD, 16) + tabBDD(cptBDD, 18) + tabBDD(cptBDD, 20)
                som5 = som5 + tabBDD(cptBDD, 19)
                som6 = som6 + tabBDD(cptBDD, 17)
            End If
            If (tabBDD(cptBDD, 23) = crit3) And (tabBDD(cptBDD, 1) = crit2) Then
                som7 = som7 + tabBDD(cptBDD, 11)
                som8 = som8 + tabBDD(cptBDD, 22)
                som9 = som9 + tabBDD(cptBDD, 12)
                som10 = som10 + tabBDD(cptBDD, 14) + tabBDD(cptBDD, 15) + tabBDD(cptBDD, 16) + tabBDD(cptBDD, 18) + tabBDD(cptBDD, 20)
                som11 = som11 + tabBDD(cptBDD, 19)
                som12 = som12 + tabBDD(cptBDD, 17)
            End If
            If (tabBDD(cptBDD, 23) = crit4) And (tabBDD(cptBDD, 1) = crit2) Then
                som13 = som13 + tabBDD(cptBDD, 11)
                som14 = som14 + tabBDD(cptBDD, 22)
                som15 = som15 + tabBDD(cptBDD, 12)
                som16 = som16 + tabBDD(cptBDD, 14) + tabBDD(cptBDD, 15) + tabBDD(cptBDD, 16) + tabBDD(cptBDD, 18) + tabBDD(cptBDD, 20)
                som17 = som17 + tabBDD(cptBDD, 19)
                som18 = som18 + tabBDD(cptBDD, 17)
            End If
           
        Next
        .Cells(2, Nlgn) = som1
        .Cells(3, Nlgn) = som2
        .Cells(4, Nlgn) = (.Cells(3, Nlgn) / som3)
        .Cells(5, Nlgn) = som4
        .Cells(6, Nlgn) = som5
        .Cells(7, Nlgn) = som6
        .Cells(8, Nlgn) = som7
        .Cells(9, Nlgn) = som8
        .Cells(10, Nlgn) = (.Cells(9, Nlgn) / som9)
        .Cells(11, Nlgn) = som10
        .Cells(12, Nlgn) = som11
        .Cells(13, Nlgn) = som12
        .Cells(14, Nlgn) = som13
        .Cells(15, Nlgn) = som14
        .Cells(16, Nlgn) = (.Cells(15, Nlgn) / som15)
        .Cells(17, Nlgn) = som16
        .Cells(18, Nlgn) = som17
        .Cells(19, Nlgn) = som18
       
      
    End With
   
    Set wsBDD = Nothing
    Set wsResult = Nothing
   
    Application.ScreenUpdating = True
   
End Sub

Merci

 

[Theze]

Bonjour,

Une piste avec un tableau :

Sub SommeReportingQE()

    Dim Nlgn As Integer
    Dim tabBDD()
    Dim wsBDD As Object
    Dim wsResult As Object
    Dim TblSom(1 To 18) As Double
    Dim crit1, crit2, crit3, crit4
    Dim cptBDD
    Dim I As Integer
   
    Nlgn = ActiveCell.Column

    Set wsBDD = Worksheets("BDD")
    Set wsResult = Worksheets("Feuil1")
  
    With wsBDD
        tabBDD = Range(.Cells(3, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 23))
    End With
  
    With wsResult
        
        Application.ScreenUpdating = False
  
        crit1 = .Cells(2, 1)
        crit2 = .Cells(1, Nlgn)
        crit3 = .Cells(8, 1)
        crit4 = .Cells(14, 1)
      
        For cptBDD = 1 To UBound(tabBDD, 1)
            If (tabBDD(cptBDD, 23) = crit1) And (tabBDD(cptBDD, 1) = crit2) Then
                TblSom(1) = TblSom(1) + tabBDD(cptBDD, 11)
                TblSom(2) = TblSom(2) + tabBDD(cptBDD, 22)
                TblSom(3) = TblSom(3) + tabBDD(cptBDD, 12)
                TblSom(4) = TblSom(4) + tabBDD(cptBDD, 14) + tabBDD(cptBDD, 15) + tabBDD(cptBDD, 16) + tabBDD(cptBDD, 18) + tabBDD(cptBDD, 20)
                TblSom(5) = TblSom(5) + tabBDD(cptBDD, 19)
                TblSom(6) = TblSom(6) + tabBDD(cptBDD, 17)
            End If
            If (tabBDD(cptBDD, 23) = crit3) And (tabBDD(cptBDD, 1) = crit2) Then
                TblSom(7) = TblSom(7) + tabBDD(cptBDD, 11)
                TblSom(8) = TblSom(8) + tabBDD(cptBDD, 22)
                TblSom(9) = TblSom(9) + tabBDD(cptBDD, 12)
                TblSom(10) = TblSom(10) + tabBDD(cptBDD, 14) + tabBDD(cptBDD, 15) + tabBDD(cptBDD, 16) + tabBDD(cptBDD, 18) + tabBDD(cptBDD, 20)
                TblSom(11) = TblSom(11) + tabBDD(cptBDD, 19)
                TblSom(12) = TblSom(12) + tabBDD(cptBDD, 17)
            End If
            If (tabBDD(cptBDD, 23) = crit4) And (tabBDD(cptBDD, 1) = crit2) Then
                TblSom(13) = TblSom(13) + tabBDD(cptBDD, 11)
                TblSom(14) = TblSom(14) + tabBDD(cptBDD, 22)
                TblSom(15) = TblSom(15) + tabBDD(cptBDD, 12)
                TblSom(16) = TblSom(16) + tabBDD(cptBDD, 14) + tabBDD(cptBDD, 15) + tabBDD(cptBDD, 16) + tabBDD(cptBDD, 18) + tabBDD(cptBDD, 20)
                TblSom(17) = TblSom(17) + tabBDD(cptBDD, 19)
                TblSom(18) = TblSom(18) + tabBDD(cptBDD, 17)
            End If
          
        Next
       
        For I = 2 To 19
            Select Case I
                Case 4, 10, 16
                    .Cells(I, Nlgn) = (.Cells(I - 3, Nlgn) / TblSom(I - 1))
                Case Else
                    .Cells(I, Nlgn) = TblSom(I)
            End Select
        Next I
     
    End With
  
    Set wsBDD = Nothing
    Set wsResult = Nothing
  
    Application.ScreenUpdating = True
  
End Sub