Macro déduire test

christine854

XLDnaute Junior
Bonjour à tous

J'ai un classeur sur lequel j'aimerai déduire en fonction des tests réussie un test final

J'ai une série de tests (test 1, 2, 3 et 4) en fonction des tests réussis (supérieur a 25 %) j'aimerais en déduire le test de résistance

Exemple : si test 1, 2 et 3 réussis alors test A
 

Pièces jointes

  • test de résistance.xlsx
    78.5 KB · Affichages: 22

Paf

XLDnaute Barbatruc
Bonjour christine854, Hieu,

un essai par fonction personnalisée:

en AA2 : =TestResistance($D$2:$H$293;Q2) et tirer vers le bas

et dans un module standard:

VB:
Function TestResistance(Plage, Produit)
Dim T As String
For Each ligne In Plage.Rows
    If ligne.Cells(1, 1) = Produit Then
        For i = 2 To Plage.Columns.Count
            If ligne.Cells(1, i) > 0.25 Then
                 T = T & i - 1 & "|"
            End If
        Next
        Exit For
    End If
Next
                  
Select Case T
    Case "1|2|3|"
            TestResistance = "Résistance A"
    Case "1|2|"
            TestResistance = "Résistance B"
    Case "1|3|"
            TestResistance = "Résistance C"
    Case "2|3|"
            TestResistance = "Résistance D"
    Case Else
        TestResistance = "--"
End Select
End Function

Pas pris en compte les tests de résistance E,F,G et H car pas compris ce qu'est la réussite à la catégorie 1,2,3 ou 4

A+
 

christine854

XLDnaute Junior
c'est pour chaque code produit j'ai différent résultat de test (de la colonne E a I, les code produit sont en colonne D)
Pour chaque test associé a un code produit si il est supérieur a 25% le test est réussit (résultat en colonne E,F,G,H)
j'aimerai qu'en colonne AA pour chaque code produit correspondant de la colonne Q en déduire en fonction des test réussit le test de résistance associé
 

Paf

XLDnaute Barbatruc
Re,

Si j'ai bien compris réussite au test 1 ou à la catégorie 1 c'est la même chose ?

Avec l'ensemble des critères :
VB:
Function TestResistance(Plage, Produit)
Dim T As String
Application.Volatile
For Each ligne In Plage.Rows
    If ligne.Cells(1, 1) = Produit Then
        For i = 2 To Plage.Columns.Count
            If ligne.Cells(1, i) > 0.25 Then
            T = T & i - 1 & "|"
            End If
        Next
        Exit For
    End If
Next
                 
Select Case T
    Case "1|", "1|4|"
            TestResistance = "Resistance E"
    Case "2|", "2|4|"
            TestResistance = "Resistance F"
    Case "3|", "3|4|"
            TestResistance = "Resistance G"
    Case "4|"
            TestResistance = "Resistance H"
    Case "1|2|3|", "1|2|3|4|"
            TestResistance = "Resistance A"
    Case "1|2|", "1|2|4|"
            TestResistance = "Resistance B"
    Case "1|3|", "1|3|4|"
            TestResistance = "Resistance C"
    Case "2|3|", "2|3|4|"
            TestResistance = "Resistance D"
    Case Else
        TestResistance = "--"
End Select
End Function

A+

Edit : Bonjour job75
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour christine854, Hieu, Paf,

C'est typiquement le cas où ce problème se résout très facilement par formule.

Voyez le fichier joint et cette formule en AA2 :
Code:
=REPT("A";SIGNE((E2>25%)*(F2>25%)*(G2>25%)*(H2<=25%)+(E2>25%)*(F2>25%)*(G2>25%)*(H2>25%)))&REPT("B";SIGNE((E2>25%)*(F2>25%)*(G2<=25%)*(H2<=25%)+(E2>25%)*(F2>25%)*(G2<=25%)*(H2>25%)))&REPT("C";SIGNE((E2>25%)*(F2<=25%)*(G2>25%)*(H2<=25%)+(E2>25%)*(F2<=25%)*(G2>25%)*(H2>25%)))&REPT("D";SIGNE((E2<=25%)*(F2>25%)*(G2>25%)*(H2<=25%)+(E2<=25%)*(F2>25%)*(G2>25%)*(H2>25%)))&REPT("E";SIGNE((E2>25%)*(F2<=25%)*(G2<=25%)*(H2<=25%)+(E2>25%)*(F2<=25%)*(G2<=25%)*(H2>25%)))&REPT("F";SIGNE((E2<=25%)*(F2>25%)*(G2<=25%)*(H2<=25%)+(E2<=25%)*(F2>25%)*(G2<=25%)*(H2>25%)))&REPT("G";SIGNE((E2<=25%)*(F2<=25%)*(G2>25%)*(H2<=25%)+(E2<=25%)*(F2<=25%)*(G2>25%)*(H2>25%)))&REPT("H";(E2<=25%)*(F2<=25%)*(G2<=25%)*(H2>25%))
Une fois qu'on a bien compris le 1er REPT("A";xxx) les autres coulent de source.

On pourrait simplifier la formule mais c'est plus clair comme cela, on adapte comme on veut.

A+
 

Pièces jointes

  • test de résistance(1).xlsx
    84.8 KB · Affichages: 19
Dernière édition:

Paf

XLDnaute Barbatruc
re,

le code proposé n'est pas une macro qui se lance, mais une fonction personnalisée.
Comme dit au post 3, on écrit la formule dans une cellule:
en AA2 : =TestResistance($D$2:$H$293;Q2) et tirer vers le bas

le code de la fonction est à copier dans un module standard.

Si vous préférez une macro à lancer, dans un module strandard :

VB:
 Sub TestR()
Dim T1, T2, i As Long, j As Long, k As Long, T As String, Test As String
With Worksheets("Feuil1")
T1 = .Range("D2:H" & .Range("D" & Rows.Count).End(xlUp).Row - 1)
T2 = .Range("Q2:Q" & .Range("Q" & Rows.Count).End(xlUp).Row)
  
For i = 1 To UBound(T2, 1)
    T = ""
    For j = 1 To UBound(T1, 1)
        If T2(i, 1) = T1(j, 1) Then
            For k = 2 To UBound(T1, 2)
                If T1(j, k) > 0.25 Then
                    T = T & k - 1 & "|"
                End If
            Next
            Exit For
        End If
    Next
    Select Case T
    Case "1|", "1|4|"
            T2(i, 1) = "Resistance E"
    Case "2|", "2|4|"
            T2(i, 1) = "Resistance F"
    Case "3|", "3|4|"
            T2(i, 1) = "Resistance G"
    Case "4|"
            T2(i, 1) = "Resistance H"
    Case "1|2|3|", "1|2|3|4|"
            T2(i, 1) = "Resistance A"
    Case "1|2|", "1|2|4|"
            T2(i, 1) = "Resistance B"
    Case "1|3|", "1|3|4|"
            T2(i, 1) = "Resistance C"
    Case "2|3|", "2|3|4|"
            T2(i, 1) = "Resistance D"
    Case Else
        T2(i, 1) = "--"
    End Select
Next
.Range("AA2").Resize(UBound(T2), 1) = T2
End With
End Sub

A+
 
Dernière édition:

Paf

XLDnaute Barbatruc
re,

une modif sur la détermination de l'affichage de résistance:
VB:
Sub TestR()
Dim T1, T2, i As Long, j As Long, k As Long, TR, TT, Result As Integer, Ind As Integer
With Worksheets("Feuil1")
T1 = .Range("D2:H" & .Range("D" & Rows.Count).End(xlUp).Row - 1)
T2 = .Range("Q2:Q" & .Range("Q" & Rows.Count).End(xlUp).Row)
TT = Array(2, 4, 8, 1)
TR = Array("H", "E", "F", "B", "G", "C", "D", "A")
For i = 1 To UBound(T2, 1)
    Result = 0
    For j = 1 To UBound(T1, 1)
        If T2(i, 1) = T1(j, 1) Then
            For k = 2 To UBound(T1, 2)
                If T1(j, k) > 0.25 Then
                    If k < UBound(T1, 2) Then
                        Result = Result + TT(k - 2)
                    Else
                        If Result = 0 Then Result = TT(k - 2)
                    End If
                End If
            Next
            Exit For
        End If
    Next
    If Result = 0 Then
      T2(i, 1) = " - - "
    Else
        Ind = (Result) / 2
        T2(i, 1) = " Résistance " & TR(Ind)
    End If
Next
.Range("AB2").Resize(UBound(T2), 1) = T2
End With
End Sub

A+
 

Paf

XLDnaute Barbatruc
re,

la même ou presque:
VB:
Sub TestR()
Dim T1, T2, i As Long, j As Long, k As Long, TR, TT, Result As Integer, Ind As Integer
With Worksheets("Feuil1")
T1 = .Range("D2:H" & .Range("D" & Rows.Count).End(xlUp).Row - 1)
T2 = .Range("Q2:Q" & .Range("Q" & Rows.Count).End(xlUp).Row)
TT = Array(2, 4, 8, 16)
TR = Array("H", "E", "F", "B", "G", "C", "D", "A")
For i = 1 To UBound(T2, 1)
    Result = 0
    For j = 1 To UBound(T1, 1)
        If T2(i, 1) = T1(j, 1) Then
            For k = 2 To UBound(T1, 2)
                If T1(j, k) > 0.25 Then
                    Result = Result + TT(k - 2)
                End If
            Next
            Exit For
        End If
    Next
    If Result = 0 Then
      T2(i, 1) = " - - "
    Else
        Ind = IIf(Result >= 16, (Result - 16) / 2, Result / 2)
        T2(i, 1) = " Résistance " & TR(Ind)
    End If
Next
.Range("AB2").Resize(UBound(T2), 1) = T2
End With
End Sub

A+
 

job75

XLDnaute Barbatruc
Re,

On peut utiliser les formules du fichier (2) en VBA :
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D:H,R:R]) Is Nothing Then Exit Sub
Dim i As Variant, j As Variant
Application.ScreenUpdating = False
Range("AB2:AB" & Rows.Count) = "" 'RAZ
Range("AB2:AB" & Rows.Count).Interior.ColorIndex = xlNone
i = Application.Match(9 ^ 9, [D:D])
j = Application.Match(9 ^ 9, [R:R])
If Not IsNumeric(i) Or Not IsNumeric(j) Then Exit Sub
Range("J2:J" & i) = "=REPT(""A"",SIGN((E2>25%)*(F2>25%)*(G2>25%)*(H2<=25%)+(E2>25%)*(F2>25%)*(G2>25%)*(H2>25%)))&REPT(""B"",SIGN((E2>25%)*(F2>25%)*(G2<=25%)*(H2<=25%)+(E2>25%)*(F2>25%)*(G2<=25%)*(H2>25%)))&REPT(""C"",SIGN((E2>25%)*(F2<=25%)*(G2>25%)*(H2<=25%)+(E2>25%)*(F2<=25%)*(G2>25%)*(H2>25%)))&REPT(""D"",SIGN((E2<=25%)*(F2>25%)*(G2>25%)*(H2<=25%)+(E2<=25%)*(F2>25%)*(G2>25%)*(H2>25%)))&REPT(""E"",SIGN((E2>25%)*(F2<=25%)*(G2<=25%)*(H2<=25%)+(E2>25%)*(F2<=25%)*(G2<=25%)*(H2>25%)))&REPT(""F"",SIGN((E2<=25%)*(F2>25%)*(G2<=25%)*(H2<=25%)+(E2<=25%)*(F2>25%)*(G2<=25%)*(H2>25%)))&REPT(""G"",SIGN((E2<=25%)*(F2<=25%)*(G2>25%)*(H2<=25%)+(E2<=25%)*(F2<=25%)*(G2>25%)*(H2>25%)))&REPT(""H"",(E2<=25%)*(F2<=25%)*(G2<=25%)*(H2>25%))"
With Range("AB2:AB" & j)
  .Formula = "=VLOOKUP(R2,D:J,7,0)"
  .Value = .Value
  .Interior.ColorIndex = 44
End With
[J:J] = ""
End Sub
La colonne J, qui reçoit (temporairement) la grande formule, est masquée.

La colonne AB est renseignée automatiquement quand on modifie des données en colonnes D à H ou R.

Fichier joint.

A+
 

Pièces jointes

  • test de résistance par VBA(1).xlsm
    91 KB · Affichages: 12

job75

XLDnaute Barbatruc
Re,

Une solution meilleure dans ce fichier (2) :
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D:H,Q:Q,AA:AA]) Is Nothing Then Exit Sub
Dim i As Variant, j As Variant
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Range("AA2:AA" & Rows.Count) = "" 'RAZ
Range("AA2:AA" & Rows.Count).Interior.ColorIndex = xlNone
i = Application.Match(9 ^ 9, [D:D])
j = Application.Match(9 ^ 9, [Q:Q])
If IsNumeric(i) And IsNumeric(j) Then
  Range("IV2:IV" & i) = "=REPT(""A"",SIGN((E2>25%)*(F2>25%)*(G2>25%)*(H2<=25%)+(E2>25%)*(F2>25%)*(G2>25%)*(H2>25%)))&REPT(""B"",SIGN((E2>25%)*(F2>25%)*(G2<=25%)*(H2<=25%)+(E2>25%)*(F2>25%)*(G2<=25%)*(H2>25%)))&REPT(""C"",SIGN((E2>25%)*(F2<=25%)*(G2>25%)*(H2<=25%)+(E2>25%)*(F2<=25%)*(G2>25%)*(H2>25%)))&REPT(""D"",SIGN((E2<=25%)*(F2>25%)*(G2>25%)*(H2<=25%)+(E2<=25%)*(F2>25%)*(G2>25%)*(H2>25%)))&REPT(""E"",SIGN((E2>25%)*(F2<=25%)*(G2<=25%)*(H2<=25%)+(E2>25%)*(F2<=25%)*(G2<=25%)*(H2>25%)))&REPT(""F"",SIGN((E2<=25%)*(F2>25%)*(G2<=25%)*(H2<=25%)+(E2<=25%)*(F2>25%)*(G2<=25%)*(H2>25%)))&REPT(""G"",SIGN((E2<=25%)*(F2<=25%)*(G2>25%)*(H2<=25%)+(E2<=25%)*(F2<=25%)*(G2>25%)*(H2>25%)))&REPT(""H"",(E2<=25%)*(F2<=25%)*(G2<=25%)*(H2>25%))"
  With Range("AA2:AA" & j)
    .Formula = "=INDEX(IV:IV,MATCH(Q2,D:D,0))" 'INDEX/EQUIV
    .Value = .Value
    .Interior.ColorIndex = 44
  End With
  [IV:IV] = ""
End If
With Me.UsedRange: End With 'actualise les barres de défilement
Application.EnableEvents = True 'réactive les évènements
End Sub
La colonne auxiliaire J est remplacée par la colonne IV.

Une fois créées les données de la colonne AA ne peuvent plus être modifiées.

Bonne fin de soirée.
 

Pièces jointes

  • test de résistance par VBA(2).xlsm
    90.8 KB · Affichages: 13

Discussions similaires

Réponses
4
Affichages
266
Réponses
40
Affichages
2 K
Réponses
17
Affichages
895

Statistiques des forums

Discussions
312 843
Messages
2 092 755
Membres
105 523
dernier inscrit
mouki62530