Régression logarithmique VBA

Bonjour,

J'essai désespéramment d'automatiser une régression logarithmique en VBA.

J'ai un classeur avec deux colonnes : en colonne A les âges et en colonne B des rémunérations.

J'essai d'effectuer la régression en utilisant la formule suivante :

y = droitereg(( plage rému ; ln( plage age)) * ln (x) + ordonnee.origine (plage rému ; ln(plage age))

Cette formule a pour but de me donner une valeur de y (rémunération médiane) pour une valeur de x choisi (qui correspond à l'âge)

J'essaie simplement de traduire cette formule en vba, sachant que j'ai préalablement identifié le numéro de ma dernière ligne pleine (car l'étendue des plages peut varier).

Mon problème est que je suis plutot débutant en vba et je ne parviens pas à sélectionner une plage finie de donnée mais qui peut varier (faut-il faire un tableau ? Utiliser set ?). Ensuite j'essai d'utiliser la fonction Linest mais cela ne fonctionne pas...

Auriez-vous la possibilité de m'aider ?

Je vous remercie d'avance.

Bien cordialement.

Bonjour Sarostique,

Pourriez-vous donner un exemple avec données et résultat attendu, merci!

Bonjour SabV,

J'ai fait un exemple avec des données aléatoires ci-joint.

Merci de votre aide !

Bonjour Sarostique,

à tester,

Sub test1()
Dim x As Integer, y As Long, Age As Range, Rémun As Range
Set Age = Range("A3:A50")
Set Rémun = Range("B3:B50")
Range("C1").Value = Evaluate("LINEST(" & Rémun.Address & ",LN(" & Age.Address & "))")
Range("D1").Value = Evaluate("INTERCEPT(" & Rémun.Address & ",LN(" & Age.Address & "))")

x = 30
y = Range("C1").Value * Application.Ln(x) + Range("D1").Value
MsgBox y
End Sub

ou bien avec les variables a et b

Sub test2()
Dim x As Double, y As Long, a, b, Age As Range, Rémun As Range
Set Age = Range("A3:A50")
Set Rémun = Range("B3:B50")
a = CVar(Evaluate("LINEST(" & Rémun.Address & ",LN(" & Age.Address & "))"))
b = Evaluate("INTERCEPT(" & Rémun.Address & ",LN(" & Age.Address & "))")
x = 30
y = Evaluate(a) * Application.Ln(x) + b
MsgBox y
End Sub

Merci beaucoup mais mon problème en fait réside dans le fait que la longueur de la série peut varier.

Dans votre exemple :

Set Age = Range("A3:A50")

Set Rémun = Range("B3:B50")

ne permettrait pas un fonctionnement optimale si la série terminait à A48 ou à l'inverse à A90 ?

pour trouver la dernière cellule renseignée de la colonne A

LastRw = Cells(Rows.Count, 1).End(xlUp).Row

avec cette variable on peut définir les plages Age et Rémun dynamiquement

Sub test2()
Dim x As Double, y As Long, LastRw As Long, a, b, Age As Range, Rémun As Range
LastRw = Cells(Rows.Count, 1).End(xlUp).Row
Set Age = Range("A3:A" & LastRw)
Set Rémun = Range("B3:B" & LastRw)
a = Evaluate("LINEST(" & Rémun.Address & ",LN(" & Age.Address & "))")
b = Evaluate("INTERCEPT(" & Rémun.Address & ",LN(" & Age.Address & "))")
x = 30
y = Evaluate(a) * Application.Ln(x) + b
MsgBox y
End Sub

aussi, tous cela peut être fait uniquement par formule,

voici un exemple:

Je test cette macro lundi et reviens vers vous.

Merci beaucoup en tout cas !

Bonjour,

Je viens d'adapter le code à ma problématique et je l'ai retesté en formule mais le résultat final diffère que ce soit sur la valeur de a ou sur la valeur de b.

Bien cordialement.


Bonjour,

Je viens d'adapter le code à ma problématique et je l'ai retesté en formule mais le résultat final diffère que ce soit sur la valeur de a ou sur la valeur de b.

Bien cordialement.

Après vérification j'ai l'impression qu'il s'agit d'un bug.

Les opérations que je demande à ma macro sont les suivantes :

1. copier / coller un onglet existant (nom de l'onglet d'origine extraction)

2. Le renommer (=médian)

3. Supprimer certaines lignes

4. Effectuer la régression logarithmique

Cette partie de code :

Set Age = Sheets("Médian").Range("O2:O" & LastRw)
Set Rémun = Sheets("Médian").Range("Z2:Z" & LastRw)

ne s'effectue pas correctement. En effet la sélection se fait sur l'onglet extraction et non sur l'onglet médian ce qui fausse le résultat.

Auriez-vous une idée de comment contourner ce problème ?

Bonjour,

Une proposition à étudier, pour le fun.

Cdlt.

Bonjour,

il faudrait que je vois comment vous avez assemblé tous ça.

Bonjour,

Voir fichier avec commentaires dans la procédure.

Cdlt.

Option Explicit

'Déclaration variables niveau module
Dim a, b

Public Sub Update_Data()
'Déclaration des variables niveau procédure
Dim n As Long
Dim X As Range, Y As Range
Dim objChart As ChartObject
Dim sr As Trendline
Dim min_X As Double, max_X As Double, min_Y As Double, max_Y As Double

    With Me
        Set objChart = .ChartObjects(1)
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        'Axe X
        Set X = .Cells(3, 1).Resize(n - 2)
        min_X = Int(WorksheetFunction.Min(X) * 0.95)
        max_X = Int(WorksheetFunction.Max(X) * 1.1)
        'Axe Y
        Set Y = .Cells(3, 2).Resize(n - 2)
        min_Y = Int(WorksheetFunction.Min(Y) * 0.95 / 1000) * 1000
        max_Y = Int(WorksheetFunction.Max(Y) * 1.05 / 1000) * 1000
        'Pente
        a = Application.LinEst(Y, Application.Ln(X))(1)
        'Ordonnée à l'origine
        b = Application.LinEst(Y, Application.Ln(X))(2)
    End With
    [E5] = a
    [E6] = b
    'Equation y = a * ln(x) + b
    [E8] = "y = " & Format(a, "#,##0.00") & " * ln(x) " & IIf(b < 0, Format(b, "#,##0.00"), " + " & Format(b, "#,##0.00"))
    With objChart.Chart
        With .FullSeriesCollection(1)
            .Trendlines(1).Delete
            .XValues = X
            .Values = Y
            'Ajout courbe de tendance
            Set sr = .Trendlines.Add
        End With
        With sr
            .Type = xlLogarithmic
            .Format.Line.ForeColor.RGB = RGB(255, 0, 0)
            .DisplayEquation = True
            .DisplayRSquared = True
        End With
        With .Axes(xlCategory)
            '.MinimumScaleIsAuto = True
            '.MaximumScaleIsAuto = True
            '.Crosses = xlAutomatic
            .MinimumScale = min_X
            .MaximumScale = max_X
            .CrossesAt = min_X
        End With
        With .Axes(xlValue)
            '.MinimumScaleIsAuto = True
            '.MaximumScaleIsAuto = True
            '.Crosses = xlAutomatic
            .MinimumScale = min_Y
            .MaximumScale = max_Y
            .CrossesAt = min_Y
        End With
    End With

    Set sr = Nothing
    Set Y = Nothing: Set X = Nothing

End Sub

Bonjour,

Pas mal Jean-Eric !

SabV je vous mets en ci-joint un fichier avec l'anomalie évoquée.

1. Ma première macro (Fiabilisation médian) génère un second onglet (intitulé médian) et supprime toutes les lignes si la colonne AB est supérieur au plafond.

2. La seconde macro (Calcul médian) doit me retourner en cellule C27 de l'onglet méthodologie le résultat du calcul.

-> Dans mon cas elle identifie la dernière ligne de l'onglet médian (soit ligne 64 dans ce cas) mais applique ensuite le calcul du médian aux 64 premières lignes de l'onglet extraction (par conséquent sans tenir compte de la suppression préalable) et me retourne donc un médian de 39850. J'ai fait le calcul manuellement (onglet Calcul manuel) et je trouve une valeur correcte de 40 296

3. Je vous ai laissé l'étape suivante, je réduis l'onglet extraction en fonction de la tranche d'âge voulu puis j'identifie le maximum, le minimum, les quartiles et la moyenne de la série. Je rencontre exactement la même difficulté que lors de l'étape précédente.

Je vous remercie de votre aide et n'hésitez pas si tout n'est pas très clair !

Bonjour,

Dans le fichier, il y 2 procédures :

  • 1 - Extraction vers Médian
    2 - Calculs et graphiques...

A étudier et adapter à tes vrais besoins.

Pour info pour 45 ans et un intervalle [40, 50], je trouve 37.987 et non pas 40.296 !...

A te relire.

Cdlt.

Bonjour,

Pouvez-vous joindre un fichier contenant l'onglet extraction ?

désolé, j'étais resté sur la 1er page, je regarde votre fichier, et vous reviens

bonjour Sarostique, Jean-Eric, le forum,

voici les modifications, à tester,

Sub test()
Dim x As Double, y As Long, a, b, Age As String, Rémun As String
Dim LastRwAge As Long, LastRwRémun As Long

'Set sh1 = Sheets("Extraction")
Set sh1 = Sheets("Médian")

LastRwAge = sh1.Cells(Rows.Count, 15).End(xlUp).Row
LastRwRémun = sh1.Cells(Rows.Count, 26).End(xlUp).Row

Age = sh1.Name & "!" & Range("O2:O" & LastRwAge).Address
Rémun = sh1.Name & "!" & Range("Z2:Z" & LastRwRémun).Address

a = CVar(Evaluate("LINEST(" & Rémun & ",LN(" & Age & "))"))
b = Evaluate("INTERCEPT(" & Rémun & ",LN(" & Age & "))")
x = 45    'à modifier pour la valeur d'un range 
y = Evaluate(a) * Application.Ln(x) + b
MsgBox y
End Sub

Bonjour à tous,

à tester, une version prenant en compte la tranche d'âge

Sub test()
Dim x As Double, y As Long, a, ax As Double, b As Double, tempo As Double, xx As Double, Age, Rémun
Dim LastRw As Long
Dim sh1, sh2, sh3
Dim AL1 As Object, AL2 As Object
Dim Tableau() As Variant

Set sh1 = Sheets("Extraction")
Set sh2 = Sheets("Méthodologie")
Set sh3 = Sheets("tempo")

sh3.Range("A2:B" & 65565).ClearContents

' en supposant que les colonnes ont tous la même qte de données que la colonne A
LastRw = sh1.Cells(Rows.Count, 1).End(xlUp).Row

ageMin = sh2.Range("C34")  ' "Méthodologie"
ageMax = sh2.Range("C35")  ' "Méthodologie"

For i = 2 To LastRw
    If Sheets("Extraction").Range("O" & i) >= ageMin And Sheets("Extraction").Range("O" & i) <= ageMax Then
    n = n + 1
        ReDim Preserve Tableau(1 To 2, 1 To n)
        Tableau(1, n) = sh1.Cells(i, 15).Value 'Récupère age
        Tableau(2, n) = sh1.Cells(i, 26).Value 'Récupère Rémun
  End If
Next

sh3.Range("A2").Resize(UBound(Tableau, 2), 2) = Application.Transpose(Tableau)

Age = sh3.Name & "!" & Range("A2:A" & sh3.Cells(Rows.Count, 1).End(xlUp).Row).Address
Rémun = sh3.Name & "!" & Range("B2:B" & sh3.Cells(Rows.Count, 2).End(xlUp).Row).Address

a = Evaluate("LINEST(" & Rémun & ",LN(" & Age & "))")
b = Evaluate("INTERCEPT(" & Rémun & ",LN(" & Age & "))")
sh2.Range("C27") = Evaluate(a) * Application.Ln(sh2.Range("C26")) + b
'Preuve avec formule
sh2.Range("E27") = Evaluate(a)
sh2.Range("F27") = b
End Sub

Jean-Eric, SabV merci pour votre aide sur le médian.

Concernant le calcul de mon maximum, minimum, quartile et moyenne j'ai essayé de le faire en passant par le gestionnaire des noms comme fait en partie par Jean-Eric, le problème est que je dois faire référence à une feuille n'existant pas initialement (la feuille tranche age) qui n'est créée que lorsque je lance une précédente macro.

J'ai ensuite essayé de le faire en vba en réadaptant le code proposé par SabV mais je pense mal définir la fonction puisqu'elle me retour l'erreur #NOM?. Vous trouverez ci-dessous le code que j'ai essayé de réadapter :

Set sh1 = Sheets("Tranche age")

LastRwRémun = sh1.Cells(Rows.Count, 26).End(xlUp).Row

Rémun = sh1.Name & "!" & Range("Z2:Z" & LastRwRémun).Address

c = Evaluate("MAX(" & Rémun & ")")
d = Evaluate("MIN(" & Rémun & ")")

Sheets("Méthodologie").Range("C39") = c
Sheets("Méthodologie").Range("C43") = d

Merci encore pour votre aide.

Bonjour,

lorsque le nom de l'onglet comporte un espace il faut ajouter une cote de chaque coté de sh1.name dans la définition de l'adresse de Rémun

Sub essai()
Set sh1 = Sheets("Tranche age")

LastRwRémun = sh1.Cells(Rows.Count, 26).End(xlUp).Row

Rémun = "'" & sh1.Name & "'!" & Range("Z2:Z" & LastRwRémun).Address

c = Evaluate("MAX(" & Rémun & ")")
d = Evaluate("MIN(" & Rémun & ")")

Sheets("Méthodologie").Range("C39") = c
Sheets("Méthodologie").Range("C43") = d
End Sub
Rechercher des sujets similaires à "regression logarithmique vba"