Automatiser une formule par VBA

Bonjour le forum,

Je cherche un moyen d'écrire une formule par VBA.

J'ai en B5:H5 des données que je veux utiliser grâce aux données présentes dans H12:N20.

Dans H13-N20, les résultats peuvent être soit 0 soit 1.

Je cherche un moyen de calculer dans le tableau présent dans Q13:W20 le résultat de la somme des jours =0 jusqu'au jour où le résultat dans H13-N20 =1

Exemples :

1. Si I13 = 1 et que dans la ligne 13 du tableau H13-N20, toutes les autres valeurs sont égales à 0 alors

R13 = 100%

2. Si I13 = 1 et K13=1 et que dans la ligne 13 du tableau H13-N20, toutes les autres valeurs sont égales à 0 alors

R13 = C5 + D5

T13 = E5 + F5 + G5 + H5 + B5

Chaque ligne est indépendante donc si I13 et K13 sont égaux à 1 cela ne sera pas forcément le cas pour la ligne 14.

Je veux calculer la somme des % entre le 1er jour où le résultat est égale à 1 et le J-1 du prochain jour où le résultat est égale à 1

Là où cela se complique, c'est s'il y a plus de valeurs égales à 1 mais j'aimerai appliquer la même logique.

Je met mon code pour avoir un aperçu. Je pense qu'il y a plus efficace mais je n'arrive pas à trouver la solution.

Sub test()
Dim x, y, yp
For x = 13 To dernligneREGLES
    For y = 8 To 14
Cells(x, 15).Value = Cells(x, 15).Value + Cells(x, y).Value
    Next y
    Next x

For x = 13 To dernligneREGLES
For y = 17 To 23
If Cells(x, 15).Value = 0 Then
Cells(x, y).Value = 0
End If
Next y
Next x

For x = 13 To dernligneREGLES
For y = 17 To 23
If Cells(x, 15).Value = 1 Then
Cells(x, y).Value = Cells(x, y - 9).Value = 0
End If
Next y
Next x

Dim i As Variant
Dim ColonneX As Integer
Dim cel As Range
Dim Valeur(1)
Dim Valeur(2)

For Each i In Range(Cells(x, 8), Cells(dernligneREGLES, 14))
If i = 1 Then
Set cel = Cells.Find(what:=i)
ColonneX = cel.Column
V(i) = ColonneX
End If
Next i

'For x = V1 To V2

End Sub

Je remercie toute personne pouvant m'aider.

Cordialement

12test-forum.xlsx (9.80 Ko)

Salut Jeff,

mieux vaut tard que jamais, dit-on...

Un double-clic démarre la macro...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tData1, tData2, tData3, dTot1#, dTot2#, iIdx%
'
Cancel = True
'
tData1 = Range("B5:H5").Value
tData2 = Range("H13:N20").Value
Range("Q13:W20").ClearContents
Range("Q13:W20").Interior.Color = xlNone
tData3 = Range("Q13:W20").Value
'
For x = 1 To UBound(tData2, 1)
    dTot1 = 0: dTot2 = 0: iIdx = 0
    For y = 1 To UBound(tData2, 2)
        dTot1 = dTot1 + IIf(iIdx = 0 And tData2(x, y) = 0, tData1(1, y), 0)                 'addition des % si "0" avant le 1er "1"
        If tData2(x, y) = 1 Then                                                            'si "1"...
            If dTot2 > 0 Then                                                               'si total % > 0, donc si déjà rencontré "1"
                tData3(x, iIdx) = dTot2 * 100                                               'tableau 3 reçoit le résultat de ce "1"
                Range("P" & x + 12).Offset(0, iIdx).Interior.Color = RGB(215, 215, 215)     'mise en couleur de ce "1"
            End If
            dTot2 = 0: iIdx = y                                                             'remise à zéro du total %  :  retient l'index du "1"
        End If
        dTot2 = dTot2 + IIf(iIdx = 0, 0, tData1(1, y))                                      'addition des % si "1" rencontré
        If y = UBound(tData2, 2) Then                                                       'si dernier jour...
            dTot2 = dTot2 + dTot1                                                           'dernière addition de %...
            tData3(x, iIdx) = dTot2 * 100                                                   'inscription du résultat dans le tableau 3
            Range("P" & x + 12).Offset(0, iIdx).Interior.Color = RGB(215, 215, 215)         'mise en couleur
        End If
    Next
Next
Range("Q13:W20").Value = tData3                                                             'affichage des résultats
'
End Sub

A+

1emballagejeff.xlsm (18.04 Ko)

Bonjour mynameisjeff,

ton pseudo à rallonge, bien qu'explicite, m'a bien déçu !

"en effet, il prouve que t'es pas celui qu'je cherchais :"
screen 1
"ni eux non plus :"


screen 2

bon, ben tant pis : j'aurai pas la prime !

dhany

Rechercher des sujets similaires à "automatiser formule vba"