alléger un code de condition

Version imprimable

bonjour,

dans ma fonction je vais chercher des valeurs dans une feuille pour faire mes calculs. Seulement voilà les valeurs en question sont nombreuses et j'aimerai pouvoir alléger ce code ci:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
public function sigma(ByVal fc, ByVal L1, ByVal L2, ByRef plageSource As Range, ByVal nomFeuilDest As String) As SingleFor Each cellule In plageSource
f=cellule.value
 If cboChoixSrce.Text = "BRH" Then
        Lws = cellule.Offset(25, 4).Value
        Lwa = cellule.Offset(0, 4).value
       elseif cboChoixSrce.Text = "scie"
       Lws= cellule.Offset(25, 5).Value
       Lwa=cellule.Offset(0, 5).value
      elseif cboChoixSrce.Text = "compresseur"
       Lws= cellule.Offset(25, 6).Value
       Lwa=cellule.Offset(0, 6).value
      elseif cboChoixSrce.Text = "perceuse"
       Lws= cellule.Offset(25, 7).Value
       Lwa=cellule.Offset(0, 7).value
       elseif cboChoixSrce.Text = "marteau"
       Lws=   cellule.Offset(25, 8).Value
       Lwa=cellule.Offset(0, 8).value
 
           '..... etc
 end if
 
  ici mes calculs
 
        End If
end function
sub ray()
 Dim plageSource As Range
    Dim nomFeuilDest As String
    sigm=sigma(...)
    nomFeuilDest = "Feuil3"                     'on définit la feuille de destination
    Set plageSource = Range("Feuil1!B5:B25")
end sub

ça continue comme ça pour une trentaine de cboChoixSrce. peut on faire moins lourd?Merci

Pour le début

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Dim Trouve As Boolean
Dim Str As String
Dim c As Range
Dim i As Byte
Dim Typ
 
If cboChoixSrce.ListIndex > -1 Then
    Str = cboChoixSrce.Text
    Set c = PlageSource.Find(Str, LookIn:=xlValues, lookat:=xlWhole)
    If Not c Is Nothing Then
        Typ = Array("BRH", "SCIE", "COMPRESSEUR", "PERCEUSE")    '...etc
        For i = 0 To UBound(Typ)
            If UCase(Str) = Typ(i) Then
                Trouve = True
                Exit For
            End If
        Next i
        If Trouve Then
            Lws = c.Offset(25, 4 + i).Value
            Lwa = c.Offset(0, 4 + i).Value
        End If
        Set c = Nothing
    End If
    'suite
End If

Merci :-)

Bonjour,

en utilisant le code pour alléger les conditions, les resultats deviennent abbérant et je ne parviens pas à trouver "l'erreur" :
Voici ma function dans un module:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
Public Function sigma(ByVal fc, ByVal L1, ByVal L2, ByRef plageSource As Range, ByVal nomFeuilDest As String) As Single
 
Dim Trouve As Boolean
Dim Str As String
Dim c As Range
Dim i As Byte
Dim Typ
 
for each c in PlageSource
f=c.value
 
   If cboChoixSrce.ListIndex > -1 Then
    Str = cboChoixSrce.Text
    Set c = plageSource.Find(Str, LookIn:=xlValues, lookat:=xlWhole)
    If Not c Is Nothing Then
        Typ = Array("Scie circulaire", "Marteau électrique", "Marteau pneumatique", "BRH", "BOBCAT", "BROKK", "Chute d'étais", _
        "Choc de marteau sur étais", "Perceuse", "Mini perceuse", "Chute de gravas", "Camion au ralentit", "Compresseur", _
        "Coulage plancher", "Aiguille vibrante", "Scie murale", "Frappe sur métal", "Hélicoptère", "Machine à enduire", _
        "Meuleuse", "Mini-pelle", "Perforateur", "Pince de démolition", "Pompe à béton", "Ponceuse plafond", _
        "Rangement d'étais", "Stop Net", "Toupie Béton Vidange")
        For i = 0 To UBound(Typ)
            If UCase(Str) = Typ(i) Then
                Trouve = True
                Exit For
            End If
        Next i
        If Trouve Then
            Lws = c.Offset(25, 1 + i).Value
            Lwa = c.Offset(0, 1 + i).Value
        End If
        Set c = Nothing
    End If
 
 
 
        sigma2 = 4 * L1 * L2 * ((f / c0) ^ 2)
        sigma3 = Sqr((2 * pi * f * (L1 + L2)) / (16 * c0))
        teta = teta0 + (Ms / (485 * Sqr(f)))
        Y = Sqr(f / fc)
 
 
 
  'Calcul de sigma
        If f11 <= (fc / 2) And f > fc Then ' => SI condition 1 validée ALORS
           sigma = 1 / Sqr(1 - (fc / f))
 
        ElseIf f11 <= (fc / 2) And f < fc And f > (fc / 2) Then  ' => SINON, SI condition 2 validée ALORS
           delta1 = ((1 - (Y ^ 2)) * Log(((1 + Y) / (1 - Y)) + (2 * Y))) / (4 * ((pi) ^ 2) * ((1 - (Y ^ 2)) ^ (1.5)))
           delta2 = 0
           sigma = (((2 * (L1 + L2) / (L1 * L2)) * (c0 / fc)) * delta1) + delta2
 
 'etc...
 
         end if
 
       epaisseur_equivalente = ThisWorkbook.Worksheets("Feuil3").Range("L28").Value
       If Lws = 0 Then
       Lwscorr = 0
       Lwas = 0
       Else
       Lwscorr = Lws - (20 * (Logd((epaisseur_equivalente) / 0.2)))
       End If
 
    'Calcul de Lwas et Lwatot
        If f < fc Then
 
          Lwas = Lwscorr - (10 * Logd(2 * pi * f * teta * Ms)) + 26 + (10 * Logd(sigma))
          Lwatot = 10 * Logd((10 ^ (0.1 * Lwas)) + (10 ^ (0.1 * Lwa)))
 
        ElseIf f = fc Then
 
          Lwas = Lwscorr - (10 * Logd(2 * pi * f * teta * Ms)) + 26 + (10 * Logd(sigma))
          Lwatot = 10 * Logd((10 ^ (0.1 * Lwas)) + (10 ^ (0.1 * Lwa)))
 
        ElseIf f > fc Then
 
          Lwas = Lwscorr - (10 * Logd(2 * pi * f * teta * Ms)) + 26 + (10 * Logd(sigma))
          Lwatot = 10 * Logd((10 ^ (0.1 * Lwas)) + (10 ^ (0.1 * Lwa)))
 
        End If
 
        J = J + 1
        Sheets(nomFeuilDest).Cells(J, 4).Value = sigma
        Sheets(nomFeuilDest).Cells(J, 6).Value = Lwas
        Sheets(nomFeuilDest).Cells(J, 7).Value = Lwatot
    End If     
    Next c
end function

Appel de la fonction:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub rayonnement()
 
    Dim sgma As Variant
    Dim plageSource As Range
    Dim nomFeuilDest As String
 
    nomFeuilDest = "Feuil3"                     'on définit la feuille de destination
    Set plageSource = Range("Feuil1!B5:B25")    'on définit la plage source pour f
 
    sgma = sigma(fc, L1, L2, plageSource, nomFeuilDest)
 
   'désallocation
    Set plageSource = Nothing
 
End Sub

c'est dans la partie soulignée du code suivant que j'aimerai arriver à introduire toutes mes sources sans faire une tonne de lignes de condition if,

Au départ j'avais ceci:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
Public Function sigma(ByVal fc, ByVal L1, ByVal L2, ByRef plageSource As Range, ByVal nomFeuilDest As String) As Single


  For Each cellule In plageSource 

        f = cellule.Value
        If UserForm1.cboChoixSrce.Text = "BRH" Then
        Lws = cellule.Offset(25, 4).Value
        Lwa = cellule.Offset(0, 4).Value
        End If       

        sigma2 = 4 * L1 * L2 * ((f / c0) ^ 2)
        sigma3 = Sqr((2 * pi * f * (L1 + L2)) / (16 * c0))
        teta = teta0 + (Ms / (485 * Sqr(f)))
        Y = Sqr(f / fc)
      
        epaisseur_equivalente = ThisWorkbook.Worksheets("Feuil3").Range("L28").Value
        Lwscorr = Lws - (20 * (Logd((epaisseur_equivalente) / 0.2)))
        
  'Calcul de sigma
        If f11 <= (fc / 2) And f > fc Then ' => SI condition 1 validée ALORS
           sigma = 1 / Sqr(1 - (fc / f))
           
        ElseIf f11 <= (fc / 2) And f < fc And f > (fc / 2) Then          
              'etc.....
         End If
        
       
        
    'Calcul de Lwas et Lwatot
        If f < fc Then
          
          Lwas = Lwscorr - (10 * Logd(2 * pi * f * teta * Ms)) + 26 + (10 * Logd(sigma))
          Lwatot = 10 * Logd((10 ^ (0.1 * Lwas)) + (10 ^ (0.1 * Lwa)))
             
        ElseIf f = fc Then
        
          Lwas = Lwscorr - (10 * Logd(2 * pi * f * teta * Ms)) + 26 + (10 * Logd(sigma))
          Lwatot = 10 * Logd((10 ^ (0.1 * Lwas)) + (10 ^ (0.1 * Lwa)))
    
        ElseIf f > fc Then
        
          Lwas = Lwscorr - (10 * Logd(2 * pi * f * teta * Ms)) + 26 + (10 * Logd(sigma))
          Lwatot = 10 * Logd((10 ^ (0.1 * Lwas)) + (10 ^ (0.1 * Lwa)))
             
        End If
                     
        J = J + 1
        Sheets(nomFeuilDest).Cells(J, 4).Value = sigma
        Sheets(nomFeuilDest).Cells(J, 6).Value = Lwas
        Sheets(nomFeuilDest).Cells(J, 7).Value = Lwatot
             
    Next cellule
 
    For i = 1 To 10
        If Sheets(nomFeuilDest).Cells(i, 4).Value = "" Then Cells(i, 4).Value = " Sigma"
        If Sheets(nomFeuilDest).Cells(i, 6).Value = "" Then Cells(i, 6).Value = " Lwas"
        If Sheets(nomFeuilDest).Cells(i, 7).Value = "" Then Cells(i, 7).Value = " Lwatot"
        
    Next i
 
    'Désallocation mémoire
    Set cellule = Nothing
    
End Function

07/08/2012, 11h55
mercatog

Soit tu n'étudie pas assez les codes qu'on te propose, soit les propositions ne sont pas assez claires et compréhensibles.

La ligne 22 suggère la comparaison de 2 mots en majuscule, avec dans Typ, tous les mots en majuscule.

Sinon, comme tu l'as écris, remplace la ligne 22 par celle-ci

Code:

If Str = Typ(i) Then

Pour le test et seulement pour tester, ajoute cette ligne juste après la ligne 29

Code:

MsgBox "i: " & i & ", Lws: " & Lws & ", Lwa: " & Lwa

Cette ligne sera supprimé quand tou fonctionne comme souhaité.

PS:Plus tard quand tu auras fais marcher le code comme souhaité, on va changer le tableau Typ où on a écrits les différents types en dur dans le code, par une plage de données dynamique sur ta feuille Config

Quand tu écris

Code:

1
2
3
4
5
Typ = Array("Scie circulaire", "Marteau électrique", "Marteau pneumatique", "BRH", "BOBCAT", "BROKK", "Chute d'étais", _
        "Choc de marteau sur étais", "Perceuse", "Mini perceuse", "Chute de gravas", "Camion au ralentit", "Compresseur", _
        "Coulage plancher", "Aiguille vibrante", "Scie murale", "Frappe sur métal", "Hélicoptère", "Machine à enduire", _
        "Meuleuse", "Mini-pelle", "Perforateur", "Pince de démolition", "Pompe à béton", "Ponceuse plafond", _
        "Rangement d'étais", "Stop Net", "Toupie Béton Vidange")

Et si ta PlageSource est B5:B25
Avec ces lignes:

Code:

1
2
                lws = c.Offset(25, 1 + i).Value
                lwa = c.Offset(0, 1 + i).Value

Tu auras Scie circulaire en colonne C, Marteau électrique en colonne D...etc (par ordre de ton tableau Typ)

07/08/2012, 12h24
panda78

Oui exactement!

J'ai compris le code mais les résultats deviennent faux et j'arrive pas à voir où ça clocle. Le code donne des valeurs de Lwas et donc de Lwatot totalement fausses en revanche les sigma sont bons...
07/08/2012, 12h41
mercatog

C'est normal que ton tableau comporte 28 items alors que plageSource 21?
Tu as fais le pas à pas pour voir les résultats intermédiaires obtenus?

Tu cherche le Type dans B5:B25 et tu décale en bas de 25 lignes et à gauche de n colonnes (en fonction du type) pour récupérer la valeur du Lws souhaité
07/08/2012, 12h50
panda78

1 pièce(s) jointe(s)

oui car j'ai 28 sources et à chaque source correspond une colonne pour Lwa et une colonne pour Lws. en piece jointe une partie de la feuille en question et du code dans un module.

Après d'innombrables tentatives échouées, j'ai écris le code de manière très simpliste et qui dis simple dis parfois très long :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
 
 
Public Function sigma(ByVal fc, ByVal L1, ByVal L2, ByRef plageSource As Range, ByVal nomFeuilDest As String) As Single
 
 
    Dim epaisseur_equivalente As Variant
     epaisseur = (UserForm1.cboEpaisParoi.Value) * 0.01
 
    teta0 = ThisWorkbook.Worksheets("Feuil3").Range("H28").Value
    sigma = 0
 
    Ms = ThisWorkbook.Worksheets("Feuil3").Range("J28").Value
 
    cL = ThisWorkbook.Worksheets("Feuil3").Range("N28").Value
    fc = (c0 ^ 2) / (1.815 * cL * epaisseur)
    f11 = ((c0 ^ 2) / (4 * fc)) * ((1 / (L1 ^ 2)) + (1 / (L2 ^ 2)))
 
For Each cellule In plageSource '<< A Ajuster à la plage ...
 
        f = cellule.Value
        If UserForm1.cboChoixSrce.Text = "Scie circulaire" Then
          Lws = cellule.Offset(25, 1).Value
          Lwa = cellule.Offset(0, 1).Value
        ElseIf UserForm1.cboChoixSrce.Text = "Marteau électrique" Then
          Lws = cellule.Offset(25, 2).Value
          Lwa = cellule.Offset(0, 2).Value
        ElseIf UserForm1.cboChoixSrce.Text = "Marteau pneumatique" Then
          Lws = cellule.Offset(25, 3).Value
          Lwa = cellule.Offset(0, 3).Value
        ElseIf UserForm1.cboChoixSrce.Text = "BRH" Then
          Lws = cellule.Offset(25, 4).Value
          Lwa = cellule.Offset(0, 4).Value
        ElseIf UserForm1.cboChoixSrce.Text = "BOBCAT" Then
          Lws = cellule.Offset(25, 5).Value
          Lwa = cellule.Offset(0, 5).Value
        ElseIf UserForm1.cboChoixSrce.Text = "BROKK" Then
          Lws = cellule.Offset(25, 6).Value
          Lwa = cellule.Offset(0, 6).Value
        ElseIf UserForm1.cboChoixSrce.Text = "Chute d'étais" Then
          Lws = cellule.Offset(25, 7).Value
          Lwa = cellule.Offset(0, 7).Value
 
       ' etc....
        ElseIf UserForm1.cboChoixSrce.Text = "Scie murale" Then
          Lws = cellule.Offset(25, 16).Value
          Lwa = cellule.Offset(0, 16).Value
        'etc...
        ElseIf UserForm1.cboChoixSrce.Text = "Toupie Béton Vidange" Then
          Lws = cellule.Offset(25, 28).Value
          Lwa = cellule.Offset(0, 28).Value
 
        End If
 
 
        sigma2 = 4 * L1 * L2 * ((f / c0) ^ 2)
        sigma3 = Sqr((2 * pi * f * (L1 + L2)) / (16 * c0))
        teta = teta0 + (Ms / (485 * Sqr(f)))
        Y = Sqr(f / fc)
 
 
 
  'Calcul de sigma
        If f11 <= (fc / 2) And f > fc Then ' => SI condition 1 validée ALORS
           sigma = 1 / Sqr(1 - (fc / f))
 
        ElseIf f11 <= (fc / 2) And f < fc And f > (fc / 2) Then    
           sigma=...
        'etc...             
        End If
 
        epaisseur_equivalente = ThisWorkbook.Worksheets("Feuil3").Range("L28").Value
 
 
    'Calcul de Lwas et Lwatot
        If Lws <> "" And f < fc Then
          Lwscorr = Lws - (20 * (Logd((epaisseur_equivalente) / 0.2)))
          Lwas = Lwscorr - (10 * Logd(2 * pi * f * teta * Ms)) + 26 + (10 * Logd(sigma))
          Lwatot = 10 * Logd((10 ^ (0.1 * Lwas)) + (10 ^ (0.1 * Lwa)))
 
        ElseIf Lws <> "" And f = fc Then
         'etc...    
 
       End If
 
        J = J + 1
        Sheets(nomFeuilDest).Cells(J, 4).Value = sigma
        Sheets(nomFeuilDest).Cells(J, 6).Value = Lwas
        Sheets(nomFeuilDest).Cells(J, 7).Value = Lwatot
 
    Next cellule
 
 
    'Désallocation mémoire
    Set cellule = Nothing
 
End Function

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub rayonnement()
 
    Dim sgma As Variant
    Dim plageSource As Range
    Dim nomFeuilDest As String
 
    nomFeuilDest = "Feuil3"                     'on définit la feuille de destination
    Set plageSource = Range("Feuil1!B5:B25")    'on définit la plage source pour f
 
    sgma = sigma(fc, L1, L2, plageSource, nomFeuilDest)
 
   'désallocation
    Set plageSource = Nothing
 
End Sub

ce code fonctionne et donne les bons résultats mais il est trop long....

07/08/2012, 17h55
mercatog

Est ce que tu peux mettre en PJ une copie de ton fichier?
07/08/2012, 18h53
Pierre Fauconnier

Salut.

Plutôt que tous tes tests avec IF, tu devrais utiliser la fonction HLOOKUP (RECHERCHEH) en VBA, parmi d'autres solutions. Ton code serait plus rapide et plus maintenable. Imagine devoir modifier ton code parce qu'un outil change d'appellation ou que tu en ajoutes un.

Tu peux utiliser HLOOLKUP avec EVALUATE ou avec Worksheetfunction. La construction de la formule est la même que dans Excel, mais tu dois formuler en anglais.

Une bonne idée est de créer la fonction dans Excel puis de la transcrire en VBA.

L'explication était erronée et la réponse l'était aussi. J'ai pas regardé de près l'intérieur de la fonction mais ayant rectifié la partie pour trouver Lwa et Lws

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
Dim cFrq As Range, c As Range
Dim Str As String
Dim i As Byte
Dim Typ
 
If UserForm1.cboChoixSrce.ListIndex > -1 Then
    With Worksheets(nomFeuilDest)
        Str = UserForm1.cboChoixSrce.Text
        Set c = ThisWorkbook.Worksheets("Feuil1").Range("C4:AD4").Find(Str, LookIn:=xlValues, lookat:=xlWhole)
        If Not c Is Nothing Then
            j = 1
            For Each cFrq In plageSource
                i = i + 1
                Lwa = c.Offset(i, 0).Value
                Lws = c.Offset(25 + i, 0).Value
                MsgBox "i: " & i & ",  Lws: " & Lws & ", Lwa: " & Lwa
                Set c = Nothing
 
                Sigma2 = 4 * L1 * L2 * ((F / C0) ^ 2)
                Sigma3 = Sqr((2 * Pi * F * (L1 + L2)) / (16 * C0))
                Teta = Teta0 + (Ms / (485 * Sqr(F)))
                Y = Sqr(F / Fc)
                'Calcul de sigma
                If F11 <= (Fc / 2) And F > Fc Then    ' => SI condition 1 validée ALORS
                    Sigma = 1 / Sqr(1 - (Fc / F))
                ElseIf F11 <= (Fc / 2) And F < Fc And F > (Fc / 2) Then    ' => SINON, SI condition 2 validée ALORS
                    Delta1 = ((1 - (Y ^ 2)) * Log(((1 + Y) / (1 - Y)) + (2 * Y))) / (4 * ((Pi) ^ 2) * ((1 - (Y ^ 2)) ^ (1.5)))
                    Delta2 = 0
                    Sigma = (((2 * (L1 + L2) / (L1 * L2)) * (C0 / Fc)) * Delta1) + Delta2
                ElseIf F11 <= (Fc / 2) And F < (Fc / 2) Then    '=> SINON
                    Delta1 = ((1 - (Y ^ 2)) * Log(((1 + Y) / (1 - Y)) + (2 * Y))) / (4 * ((Pi) ^ 2) * ((1 - (Y ^ 2)) ^ (1.5)))
                    Delta2 = (8 * (C0 ^ 2) * (1 - (2 * (Y ^ 2)))) / ((Fc ^ 2) * (Pi ^ 4) * L1 * L2 * Y * Sqr(1 - (Y ^ 2)))
                    Sigma = (((2 * (L1 + L2) / (L1 * L2)) * (C0 / Fc)) * Delta1) + Delta2
                ElseIf F11 < (Fc / 2) And F < F11 And Sigma > Sigma2 Then
                    Sigma = Sigma2
                ElseIf F11 > (Fc / 2) And F < Fc And Sigma2 < Sigma3 Then
                    Sigma = Sigma2
                ElseIf F11 > (Fc / 2) And F < Fc And Sigma2 > Sigma3 Then
                    Sigma = Sigma3
                ElseIf F11 > (Fc / 2) And F > Fc And 1 < Sigma3 * Sqr(Abs(1 - (Fc / F))) Then
                    Sigma = 1 / Sqr(1 - (Fc / F))
                ElseIf F11 > (Fc / 2) And F > Fc And 1 > Sigma3 * Sqr(Abs(1 - (Fc / F))) Then
                    Sigma = Sigma3
                Else
                    MsgBox "Erreur : Veuillez reconsidérez les dimensions de la paroi excitée"
                    Exit Function
                End If
                Epaisseur_Equivalente = ThisWorkbook.Worksheets("Feuil3").Range("L28").Value
                Lwscorr = Lws - (20 * (Logd((Epaisseur_Equivalente) / 0.2)))
                'Calcul de Lwas et Lwatot
                If Lws = 0 Then
                    Lwatot = 10 * Logd((10 ^ (0.1 * Lwas)) + (10 ^ (0.1 * Lwa)))
                Else
                    If F < Fc Then
                        Lwas = Lwscorr - (10 * Logd(2 * Pi * F * Teta * Ms)) + 26 + (10 * Logd(Sigma))
                        Lwatot = 10 * Logd((10 ^ (0.1 * Lwas)) + (10 ^ (0.1 * Lwa)))
                    ElseIf F = Fc Then
                        Lwas = Lwscorr - (10 * Logd(2 * Pi * F * Teta * Ms)) + 26 + (10 * Logd(Sigma))
                        Lwatot = 10 * Logd((10 ^ (0.1 * Lwas)) + (10 ^ (0.1 * Lwa)))
                    ElseIf F > Fc Then
                        Lwas = Lwscorr - (10 * Logd(2 * Pi * F * Teta * Ms)) + 26 + (10 * Logd(Sigma))
                        Lwatot = 10 * Logd((10 ^ (0.1 * Lwas)) + (10 ^ (0.1 * Lwa)))
                    End If
                End If
                j = j + 1
                .Cells(j, 4).Value = Sigma
                .Cells(j, 6).Value = Lwas
                .Cells(j, 7).Value = Lwatot
            Next cFrq
        End If
 
        .Cells(1, 4).Value = " Sigma"
        .Cells(1, 6).Value = " Lwas"
        .Cells(1, 7).Value = " Lwatot"
    End With
End If
End Function

Bonjour,
ce n'est pas pas bon VBA me donne des résultas abérrants de Lwa et Lws et du coup de Lwas et Lwatot

il faudrait le version allégée de ce code ci :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
For Each cellule In plageSource '<< A Ajuster à la plage ...
 
        F = cellule.Value
 
        If UserForm1.cboChoixSrce.Text = "Scie circulaire" Then
          Lws = cellule.Offset(25, 1).Value
          Lwa = cellule.Offset(0, 1).Value
 
        ElseIf UserForm1.cboChoixSrce.Text = "Marteau électrique" Then
          Lws = cellule.Offset(25, 2).Value
          Lwa = cellule.Offset(0, 2).Value
 
        ElseIf UserForm1.cboChoixSrce.Text = "Marteau pneumatique" Then
          Lws = cellule.Offset(25, 3).Value
          Lwa = cellule.Offset(0, 3).Value
 
        ElseIf UserForm1.cboChoixSrce.Text = "BRH" Then
          Lws = cellule.Offset(25, 4).Value
          Lwa = cellule.Offset(0, 4).Value
 
        ElseIf UserForm1.cboChoixSrce.Text = "BOBCAT" Then
          Lws = cellule.Offset(25, 5).Value
          Lwa = cellule.Offset(0, 5).Value
 
        ElseIf UserForm1.cboChoixSrce.Text = "BROKK" Then
          Lws = cellule.Offset(25, 6).Value
          Lwa = cellule.Offset(0, 6).Value
 
        ElseIf UserForm1.cboChoixSrce.Text = "Chute d'étais" Then
          Lws = cellule.Offset(25, 7).Value
          Lwa = cellule.Offset(0, 7).Value
 
        ElseIf UserForm1.cboChoixSrce.Text = "Choc de marteau sur étais" Then
          Lws = cellule.Offset(25, 8).Value
          Lwa = cellule.Offset(0, 8).Value
 
        ElseIf UserForm1.cboChoixSrce.Text = "Perceuse" Then
          Lws = cellule.Offset(25, 9).Value
          Lwa = cellule.Offset(0, 9).Value
 
       'etc.......
         End If

Ce code fonctionne bien vba donne les bons résultats, par contre il est trop long...

08/08/2012, 10h18
Pierre Fauconnier
cfr ma réponse précédente.

Au lieu des IF, tu DOIS passer soit:
par une formule Excel transposée et évaluée en VBA;
par la méthode FIND pour trouver la cellule de l'outil puis par décalage par rapport à cette cellule.

Dans Excel, tu pourrais utiliser RECHERCHEH pour trouver une valeur dépendant d'un outil.

http://fauconnier.developpez.com/for...-08_100557.png

En transposant cette formule en VBA, tu pourrais avoir un code du genre
Code:

1 2 3 4 5 6 7 Sub Test() Dim Valeur As Variant Dim Outil As String Outil = "Marteau" Valeur = Evaluate("HLOOKUP(""" & Outil & """,feuil1!C1:E2,2,0)") End Sub
http://fauconnier.developpez.com/for...-08_101546.png

Ce code remplace tous tes if imbriqués et générisent ton code, de sorte qu'à l'ajout d'un outil, seule la plage doive être redimensionnée. Si tu utilises une plage nommée avec DECALER, tu ne dois même plus t'en soucier dans le code => que du bonheur.
08/08/2012, 10h34
panda78

oui mais j'ai 20 valeurs en colonne pour chaque outil (28 outils) , comment faire dans ce cas? ex : Marteau=Range("Feuil1!D5: D25")

PS: que représente le 2,0 dans :

Code:

(feuil1!C1:E2,2,0)

On avait oublié d'affecter F=cFrq.Value!

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
Dim cFrq As Range, c As Range
Dim Str As String
Dim i As Byte
Dim Typ
 
If UserForm1.cboChoixSrce.ListIndex > -1 Then
    With Worksheets(nomFeuilDest)
        Str = UserForm1.cboChoixSrce.Text
        Set c = ThisWorkbook.Worksheets("Feuil1").Range("C4:AD4").Find(Str, LookIn:=xlValues, lookat:=xlWhole)
        If Not c Is Nothing Then
            j = 1
            For Each cFrq In plageSource
                i = i + 1
                Lwa = c.Offset(i, 0).Value
                Lws = c.Offset(25 + i, 0).Value
                MsgBox "i: " & i & ",  Lws: " & Lws & ", Lwa: " & Lwa
                Set c = Nothing
                f = cFrq.Value
                Sigma2 = 4 * L1 * L2 * ((f / C0) ^ 2)
                Sigma3 = Sqr((2 * Pi * f * (L1 + L2)) / (16 * C0))
                Teta = Teta0 + (Ms / (485 * Sqr(f)))
                Y = Sqr(f / Fc)
                'Calcul de sigma
                If F11 <= (Fc / 2) And f > Fc Then    ' => SI condition 1 validée ALORS
                    Sigma = 1 / Sqr(1 - (Fc / f))
                ElseIf F11 <= (Fc / 2) And f < Fc And f > (Fc / 2) Then    ' => SINON, SI condition 2 validée ALORS
                    Delta1 = ((1 - (Y ^ 2)) * Log(((1 + Y) / (1 - Y)) + (2 * Y))) / (4 * ((Pi) ^ 2) * ((1 - (Y ^ 2)) ^ (1.5)))
                    Delta2 = 0
                    Sigma = (((2 * (L1 + L2) / (L1 * L2)) * (C0 / Fc)) * Delta1) + Delta2
                ElseIf F11 <= (Fc / 2) And f < (Fc / 2) Then    '=> SINON
                    Delta1 = ((1 - (Y ^ 2)) * Log(((1 + Y) / (1 - Y)) + (2 * Y))) / (4 * ((Pi) ^ 2) * ((1 - (Y ^ 2)) ^ (1.5)))
                    Delta2 = (8 * (C0 ^ 2) * (1 - (2 * (Y ^ 2)))) / ((Fc ^ 2) * (Pi ^ 4) * L1 * L2 * Y * Sqr(1 - (Y ^ 2)))
                    Sigma = (((2 * (L1 + L2) / (L1 * L2)) * (C0 / Fc)) * Delta1) + Delta2
                ElseIf F11 < (Fc / 2) And f < F11 And Sigma > Sigma2 Then
                    Sigma = Sigma2
                ElseIf F11 > (Fc / 2) And f < Fc And Sigma2 < Sigma3 Then
                    Sigma = Sigma2
                ElseIf F11 > (Fc / 2) And f < Fc And Sigma2 > Sigma3 Then
                    Sigma = Sigma3
                ElseIf F11 > (Fc / 2) And f > Fc And 1 < Sigma3 * Sqr(Abs(1 - (Fc / f))) Then
                    Sigma = 1 / Sqr(1 - (Fc / f))
                ElseIf F11 > (Fc / 2) And f > Fc And 1 > Sigma3 * Sqr(Abs(1 - (Fc / f))) Then
                    Sigma = Sigma3
                Else
                    MsgBox "Erreur : Veuillez reconsidérez les dimensions de la paroi excitée"
                    Exit Function
                End If
                Epaisseur_Equivalente = ThisWorkbook.Worksheets("Feuil3").Range("L28").Value
                Lwscorr = Lws - (20 * (Logd((Epaisseur_Equivalente) / 0.2)))
                'Calcul de Lwas et Lwatot
                If Lws = 0 Then
                    Lwatot = 10 * Logd((10 ^ (0.1 * Lwas)) + (10 ^ (0.1 * Lwa)))
                Else
                    If f < Fc Then
                        Lwas = Lwscorr - (10 * Logd(2 * Pi * f * Teta * Ms)) + 26 + (10 * Logd(Sigma))
                        Lwatot = 10 * Logd((10 ^ (0.1 * Lwas)) + (10 ^ (0.1 * Lwa)))
                    ElseIf f = Fc Then
                        Lwas = Lwscorr - (10 * Logd(2 * Pi * f * Teta * Ms)) + 26 + (10 * Logd(Sigma))
                        Lwatot = 10 * Logd((10 ^ (0.1 * Lwas)) + (10 ^ (0.1 * Lwa)))
                    ElseIf f > Fc Then
                        Lwas = Lwscorr - (10 * Logd(2 * Pi * f * Teta * Ms)) + 26 + (10 * Logd(Sigma))
                        Lwatot = 10 * Logd((10 ^ (0.1 * Lwas)) + (10 ^ (0.1 * Lwa)))
                    End If
                End If
                j = j + 1
                .Cells(j, 4).Value = Sigma
                .Cells(j, 6).Value = Lwas
                .Cells(j, 7).Value = Lwatot
            Next cFrq
        End If
 
        .Cells(1, 4).Value = " Sigma"
        .Cells(1, 6).Value = " Lwas"
        .Cells(1, 7).Value = " Lwatot"
    End With
End If
End Function

RECHERCHEH fonctionne comme RECHERCHEV, mais en inversant les axes.

Dans mon exemple, on cherche donc "Marteau" sur C1:E1, et lorsqu'on l'a trouvé, on va sur la DEUXIEME ligne de la plage, dans la même colonne

Citation:

=RECHERCHEH("Marteau";C1:E2;2;0)

0 en quatrième paramètre signifie que tu cherche une correspondance exacte, et donc que tu cherches Marteau et pas la valeur inférieure la plus approchante.

La syntaxe VBA ne diffère pas de celle d'Excel, et le fonctionnement non plus.

Donc, tu récupères la valeur de la liste déroulante de ton form et tu l'utilises pour retrouver une valeur dans la même colonne sur une ligne voulue.

Une autre solution, plus pratique si tu dois récupérer plusieurs valeurs de "Marteau", c'est d'utiliser une cellule puis de décaler par rapport à cette cellule.

Toujours sur base de mon exemple
Code:

1 2 3 4 5 6 7 8 9 Dim Cellule As Range Dim Outil As String Dim Valeur As Variant Outil = "Marteau" Set Cellule = Range("c1:e1").Find(what:=Outil, LookIn:=xlValues, lookat:=xlWhole) If Not Cellule Is Nothing Then 'Si on trouve une correspondance, Cellule pointe vers la cellule qui contient "Marteau" Valeur = Cellule.Offset(1, 0) End If
Tu vois, au travers de ces exemples, que tu libères ton code de données "en dur".

A toi d'adapter à ton code.

08/08/2012, 12h05
Pierre Fauconnier

En fait, je repartais sur ton exemple avec les IF, alors que Mercatog, que je salue au passage, t'avait déjà donné une solution avec FIND.

Tu aurais intérêt à exécuter le bloc en pas à pas pour comprendre chaque ligne. Cela te permettrait d'adapter à ton classeur en comprenant ce que tu fais.
08/08/2012, 13h49
panda78

j'arrete pas d'essayer depuis ces deux jours mais rien y fait vba m'envoi constamment des résultats abérrants alors que mon code tout plein de if me donne les bons. Je craque :cry: