Lisser courbe, macro? Prog?

Version imprimable

Voir 40 message(s) de cette discussion en une page

18/07/2011, 18h11
docjam71

Bonjour,

J'ai des données assez conséquentes ( ça peut aller jusqu'à' 18000 cellules). Pour résumé, j'ai un signal " sinusoïdale" centré sur 0 (ça ressemble plus à un signal carré ou la partie haute (ou basse si on est en négatif) varie). Le but est de récupérer la moyenne du min et du max pour chaque variation de la partie haute et faire ça pour chaque "sinusoïde". Vous me suivez?

Je me suis arrangé pour supprimer la partie négative. Ceci se retrouve à 0. J'ai pris le cas de celui qui avait le moins de points (6000 cellules quand même) ou j'ai fait une macro. Pour chaque "carré" je calcul le max etc....c'est long...

En sachant que mes données changent à chaque fois car il n'y a pas le même nombres de points.

Quelle est la meilleur solution? en réalité je cherche à lisser mes courbes pour chaque max récupéré.

Merci! ;)

PS : je suis sur Excel 2010

Re,

Pour expliquer un peut mieux ce que je veux faire :

j'ai une courbe à 2 dimensions (X>0) par contre les Y positifs et négatifs.

Est-il possible de créer un programme sur VB pour dire : à partir de telle ligne telle colonne (Y), sélectionner la première série de points positifs et calculer le max, puis la 2ième série de points positifs et calculer le max....ainsi de suite jusqu'à la dernière série positive.

Merci!

:roll:

Bonjour

Une proposition (gymnastique)

Ton fichier: Données en Feuil1: X en A2:Axx et Y en B2:Bxx.
On récupère Y* en C2:Cxx (résultats après modification des valeurs positives de Y).

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
Private Sub Lissage()
Dim LastLig As Long, i As Long, j As Long, k As Long
Dim First As Boolean
Dim S As Double
Dim Tb, Res()
 
Application.ScreenUpdating = False
With Sheets("Feuil1")
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    Tb = .Range("B2:B" & LastLig)
    Do While i < LastLig - 1
        i = i + 1
        If Tb(i, 1) > 0 Then
            If Not First Then
                k = 1
                First = True
                j = j + 1
                ReDim Preserve Res(1 To 2, 1 To j)
                Res(1, j) = i
            Else
                k = k + 1
            End If
        Else
            First = False
        End If
        If First Then Res(2, j) = k
    Loop
    For j = 1 To UBound(Res, 2)
        S = Fmax(Res(1, j), Res(2, j), Tb)
        For i = Res(1, j) To Res(1, j) + Res(2, j) - 1
            Tb(i, 1) = S
        Next i
    Next j
    .Range("C1") = "Y*"
    .Range("C2:C" & LastLig) = Tb
End With
End Sub
 
'Cherche le max d'une partie commençant en m et de taille n de MonTab
Private Function Fmax(ByVal m As Long, ByVal h As Long, ByRef MonTab As Variant) As Double
Dim i As Integer
Dim S As Double
 
S = MonTab(m, 1)
If h > 1 Then
    For i = m + 1 To m + h - 1
        If MonTab(i, 1) > S Then S = MonTab(i, 1)
    Next i
End If
Fmax = S
End Function

19/07/2011, 15h01
docjam71

Merci mercatog! Pas mal du tout ;)

Par contre es-ce que tu pourrais m'expliquer ligne par ligne ce que tu fais?

Avec ton code, pour une série positive, il repère le max et le met sur tous les valeurs de la série. Je voudrais simplement récupérer une valeur du max pour chaque série positive pour me faciliter la tâche après pour le tracé de la courbe.

Thanks!
19/07/2011, 15h17
mercatog

Le code parcours ligne par ligne la colonne B.
à la première valeur positive elle met la ligne correspondante dans le tableau Res(1,xx). ensuite il continu son parcours jusqu’à' à la valeur suivante négative. Le nombre de lignes trouvées est mis dans Res(2,xx).
Et recommence son chemin jusqu'à la dernière cellule remplie.

A la fin on se retrouve avec un tableau Res comprenant les débuts des séries positives et la "portée" de chacune.

Exemple avec cette série de donnée commençant en B2:
B2: -13
B3: 24
B4: 13
B5: 15
B6: -6
B7: -7
B8: 24
B9: 26
B10: -17
On aura un tableau Res comme ceci:

Res(1,1) = 3 (Première série commence en ligne 3)
Res(2,1)=3 (Première série a 3 valeurs positives)
Res(1,2)=8 (Deuxième série commence en ligne 8)
Res(2,2)=2 (deuxième série a 2 valeurs positives)

La fonction Fmax permet de calculer le maximum de chaque série (connaissant où elle commence et combien elle comporte de valeurs).

Citation:

Je voudrais simplement récupérer une valeur du max pour chaque série positive

Que veux tu en faire?
19/07/2011, 15h53
docjam71

Ok j'ai compris,

Exemple pour la 1ère série positive, j'ai :

B2 : 0,12
B3 : 0,145
B4 : 0,1506
B5 : 0,22
Bn : 0,2

On récupère :

C2 : 0,22
C3 : 0,22
C4 : 0,22
C5 : 0,22
Cn : 0,22

Or je ne veux lisser ma courbe que pour une valeur max de chaque série positive.
Il me faut tracé pour chaque Ymax son X correspondant.

Merci.
19/07/2011, 16h05
mercatog

C'est à dire? avec ton exemple tu veux obtenir quoi?
19/07/2011, 16h17
docjam71

Avoir :

1ère série : (A5;B5)
2ième série (A17;B17)
énième série (An;Bn)

Pour chaque Y balayé (série positive toujours), on récupère le Y max puis son X correspondant.

Au final on trace Ymax=f(X).

;)

[Edit]
Ci-joint une autre proposition

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
Private Sub Cretes()
Dim LastLig As Long, i As Long, j As Long, Pos As Long
Dim Tb, Res() As Double, P As Double
Dim First As Boolean
 
Application.ScreenUpdating = False
With Sheets("Feuil1")
    .Range("C:D").ClearContents
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    Tb = .Range("A2:B" & LastLig + 1)
    Do While i < LastLig
        i = i + 1
        If Tb(i, 2) > 0 Then
            If Not First Then
                First = True
                P = Tb(i, 2)
                Pos = i
            Else
                If Tb(i, 2) > P Then
                    P = Tb(i, 2)
                    Pos = i
                End If
            End If
        Else
            If First Then
                j = j + 1
                ReDim Preserve Res(1 To 2, 1 To j)
                Res(1, j) = Tb(Pos, 1)
                Res(2, j) = P
                First = False
            End If
        End If
    Loop
    If j > 0 Then
        .Range("C1:D1") = Array("X", "Y*")
        .Range("C2").Resize(UBound(Res, 2), 2) = Application.Transpose(Res)
    End If
End With
End Sub

20/07/2011, 08h03
docjam71

Super! ça marche nikel!

Merci mercatog.

J'ai un autre souci que j'expliquerai ultérieurement.

Même principe que tout à l'heure pour l'explication du code?

Y-a t-il un tuto sur VB ici sur le site?

:ccool:
14/09/2011, 17h01
docjam71

Bonsoir,

Je reviens vers vous pour mon histoire de lissage.

Je voudrais maintenant récupérer le min au lieu du max que le code de mercatog génère.

Ainsi : à partir de la 1ère variation où Yn-1 < Yn > Yn+1 jusqu'à la dernière variation où Yx-1 < Yx > Yx+1, me récupérer entre [Yn;Yx] le Ymin avec son X correspondant.

Et faire ça comme précédemment toujours pour les séries positives.

Je ne sais pas si je suis clair.

Merci.

;)
14/09/2011, 23h01
mercatog

Bonsoir
C'est pourquoi il fallait comprendre le code
Pour trouver le min à la place du max, change > par < en ligne 19
15/09/2011, 13h49
docjam71

Bonjour,

Oui j'ai essayé de changer ce signe mais ça ne marche pas comme je le souhaite.
Je m'explique :

Si je change le signe en ligne 19, le code me récupère le point le plus petit. Or, j'ai un signal "carré" ou la crête varie comme des vagues irrégulières. Je voudrais récupérer le min dans cette partie haute du signal carré comme pour le max.

Donc le code doit calculé le min à partir de Xn+4 jusqu'à Xn-4 car je considère d'après mes signaux que la crête débute à partir du 4ième point et fini 4 points avant, c'est ainsi pour chaque signal.

Donc récupérer le Ymin pour X compris entre [Xn+4; Xn-4] et ainsi pour chaque série positive.

Merci.

Au final il me faudrait un code générale ou j'aurais à partir des donnés brute X et Y, 5 colonnes : Ymax avec son X, Ymin avec son X [Xn+4;Xn-4] et la moyenne de Ymin et Ymax.
08/11/2011, 11h03
docjam71

Bonjour,

Puis-je à partir des donnés brute X et Y généré 3 colonnes qui me donneront grâce à VB : Ymax avec son X, Ymin avec son X [Xn+4;Xn-4] et la moyenne de Ymin et Ymax?

Merci

Une proposition
Colonne A: X, Colonne B: Y et le code génère en Colonne C: Y_Lissée
la courbe initiale Y est une courbe carrée avec alternance de créneaux positifs et autres négatifs.

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
Sub Lissage()
Dim LastLig As Long, i As Long, j As Long, k As Long
Dim dMn As Double, dMx As Double
Dim Tb
 
Application.ScreenUpdating = False
With Worksheets("Feuil1")
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    Tb = .Range("A1:C" & LastLig)
    Tb(1, 3) = "Y_Lissée"
    i = 2
    Do While i < LastLig
        If Tb(i, 2) * Tb(i + 1, 2) <= 0 Then                         'au cas de changement de signe des valeurs
            dMx = Mx(Tb, i - j, j)
            dMn = Mn(Tb, i - j, j)
            For k = i - j To i
                Tb(k, 3) = (dMx + dMn) / 2
            Next k
            j = 0
        Else
            j = j + 1
        End If
        i = i + 1
    Loop
    .Range("A1:C" & LastLig) = Tb
End With
End Sub
 
Private Function Mx(Tb, ByVal Deb As Long, Nb As Long) As Double
Dim M As Double
Dim k As Long
 
M = Tb(Deb, 2)
For k = Deb + 1 To Deb + Nb
    If Abs(Tb(k, 2)) > Abs(M) Then M = Tb(k, 2)
Next k
Mx = M
End Function
Private Function Mn(Tb, ByVal Deb As Long, Nb As Long) As Double
Dim M As Double
Dim k As Long
 
M = Tb(Deb, 2)
For k = Deb + 1 To Deb + Nb
    If Abs(Tb(k, 2)) < Abs(M) Then M = Tb(k, 2)
Next k
Mn = M
End Function

08/11/2011, 17h55
docjam71

Bonjour,

J'ai un signal "carré" ou la crête présente des vagues irrégulières. Je voudrais récupérer le min dans cette partie haute du signal carré comme pour le max du code Crêtes plus bas.

Donc le code doit calculé le min à partir de Xn+4 jusqu'à Xn-4 car je considère d'après mes signaux que la crête débute à partir du 4ième point et fini 4 points avant, c'est ainsi pour chaque signal.

Donc récupérer le Ymin pour X compris entre [Xn+4; Xn-4] et ainsi pour chaque série positive. La série négative ne m'intéresse pas.

Ton code me génère qu'une seule colonne, et j'obtiens un signal carré!

J'aurais voulu à partir des donnés brute X et Y, 3 colonnes en plus : Ymax avec son X, Ymin avec son X [Xn+4;Xn-4] et la moyenne de Ymin et Ymax.

Un code peut-il générer les 3 colonnes en même temps?

Merci

Je suis entrain de faire un devoir surveillé (un fichier de données serait nécessaire).

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
Sub Lissage()
Dim LastLig As Long, i As Long, j As Long, k As Long
Dim dMn As Double, dMx As Double
Dim Tb
 
Application.ScreenUpdating = False
With Worksheets("Feuil1")
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    Tb = .Range("A1:E" & LastLig)
    Tb(1, 3) = "Y_Max": Tb(1, 4) = "Y_Min": Tb(1, 5) = "Y_Moy"
    i = 2
    Do While i < LastLig
        If Tb(i, 2) * Tb(i + 1, 2) <= 0 Then                         'au cas de changement de signe des valeurs
            dMx = Mx(Tb, i - j, j)
            dMn = Mn(Tb, i - j, j)
            For k = i - j To i
                Tb(k, 3) = dMx
                Tb(k, 4) = dMn
                Tb(k, 5) = (dMx + dMn) / 2
            Next k
            j = 0
        Else
            j = j + 1
        End If
        i = i + 1
    Loop
    .Range("A1:E" & LastLig) = Tb
End With
End Sub
 
Private Function Mx(Tb, ByVal Deb As Long, Nb As Long) As Double
Dim M As Double
Dim k As Long
 
M = Tb(Deb, 2)
For k = Deb + 1 To Deb + Nb
    If Abs(Tb(k, 2)) > Abs(M) Then M = Tb(k, 2)
Next k
Mx = M
End Function
Private Function Mn(Tb, ByVal Deb As Long, Nb As Long) As Double
Dim M As Double
Dim k As Long
 
M = Tb(Deb, 2)
For k = Deb + 1 To Deb + Nb
    If Abs(Tb(k, 2)) < Abs(M) Then M = Tb(k, 2)
Next k
Mn = M
End Function

09/11/2011, 09h11
docjam71

Bonjour,

Je ne veux récupérer que la valeur Max et Min pour chaque série positive avec leur X correspondant.

Il me faut tracé pour chaque Ymin son X correspondant comme le code Sub Crêtes plus haut qui marche nickel pour Ymax.

Sauf que je voudrais un code général qui génère le Ymax avec son X, le Ymin avec son X puis la moyenne de Ymin et Ymax.

Il y a donc 5 colonnes en plus des valeurs brutes X et Y.

Le dernier code me génère un signal carré or je veux lisser le signal que dans la partie haute de la crête pour chaque série positive.

Ci-joint un fichier de données.

Merci

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
Sub Lissage()
Dim LastLig As Long, i As Long, j As Long, k As Long, n As Long
Dim dMn As Double, dMx As Double
Dim Tb
 
Application.ScreenUpdating = False
With Worksheets("Feuil5")
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    Tb = .Range("A1:E" & LastLig)
    Tb(1, 3) = "Y_Max": Tb(1, 4) = "Y_Min": Tb(1, 5) = "Y_Moy"
    i = 2
    Do While i < LastLig
        If Abs(Tb(i + 1, 2) - Tb(i, 2)) > 0.1 * Tb(i, 2) Then          'au cas de changement de plus de 10%
            dMx = Mx(Tb, i - j, j)
            dMn = Mn(Tb, i - j, j)
            For k = i - j To i
                Tb(k, 3) = dMx
                Tb(k, 4) = dMn
                Tb(k, 5) = (dMx + dMn) / 2
            Next k
            j = 0
        Else
            j = j + 1
        End If
        i = i + 1
    Loop
    .Range("A1:E" & LastLig) = Tb
End With
End Sub
 
Private Function Mx(Tb, ByVal Deb As Long, Nb As Long) As Double
Dim m As Double
Dim k As Long
 
m = Tb(Deb, 2)
For k = Deb + 1 To Deb + Nb
    If Abs(Tb(k, 2)) > Abs(m) Then m = Tb(k, 2)
Next k
Mx = m
End Function
 
Private Function Mn(Tb, ByVal Deb As Long, Nb As Long) As Double
Dim m As Double
Dim k As Long
 
m = Tb(Deb, 2)
For k = Deb + 1 To Deb + Nb
    If Abs(Tb(k, 2)) < Abs(m) Then m = Tb(k, 2)
Next k
Mn = m
End Function

09/11/2011, 13h51
docjam71

Ok!

Mais sur la même logique que pour le code du lissage Max (voir code Crêtes plus haut et fichier données ci-joint) que cela donne t-il pour le lissage Min? restons à 10%.

Merci

Ci-joint fichier données.

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
Option Explicit
 
Sub Lissage()
Dim LastLig As Long, i As Long, j As Long
Dim P As Double, Q As Double
Dim Tb, Ind()
 
Application.ScreenUpdating = False
With Worksheets("Feuil5")
    .Range("C:E").ClearContents
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    Tb = .Range("A1:E" & LastLig)
    Tb(1, 3) = "Y_Max": Tb(1, 4) = "Y_Min": Tb(1, 5) = "Y_Moy"
 
    Ind = Maxim(Tb)
 
    For j = 1 To UBound(Ind, 2) - 1
        P = Ind(3, j)
        Q = Ind(3, j)
        For i = Ind(1, j) + 4 To Ind(1, j) + Ind(2, j) - 5
            Q = IIf(Tb(i, 2) < Q, Tb(i, 2), Q)
        Next i
        For i = Ind(1, j) To Ind(1, j + 1) - 1
            Tb(i, 3) = P
            Tb(i, 4) = Q
            Tb(i, 5) = (P + Q) / 2
        Next i
    Next j
    .Range("A1:E" & LastLig) = Tb
End With
End Sub
 
Private Function Maxim(Tb) As Variant
Dim i As Long, j As Long, k As Long, Pos As Long
Dim First As Boolean
Dim P As Double
Dim Temp()
 
For i = 2 To UBound(Tb, 1)
    If Tb(i, 2) >= 0 Then
        If Not First Then Pos = i
        P = IIf(Tb(i, 2) > P, Tb(i, 2), P)
        First = True
        j = j + 1
    Else
        If First Then
            k = k + 1
            ReDim Preserve Temp(1 To 3, 1 To k)
            Temp(1, k) = Pos
            Temp(2, k) = j
            Temp(3, k) = P
            First = False
            j = 0
            P = 0
        End If
    End If
Next i
Maxim = Temp
End Function

Voir 40 message(s) de cette discussion en une page

Fuseau horaire GMT +2. Il est actuellement 01h03.