'Esta rotina ajusta pontos diversos em curvas algébricas
Sub Multifit()
    Dim i As Integer, j As Integer, k As Integer, M As Single, N As Single
    Dim X(50) As Single, Y(50) As Single
    Dim r As Range, s As Range
    Dim a1 As Single, a2 As Single
    Dim sx As Single, sy As Single, sxy As Single, sx2 As Single, sy2 As Single
    Dim r2 As Single
    Dim Xmin As Single, Xmax As Single, dx As Single
    Dim TemzeroX As Boolean, TemzeroY As Boolean
    
'    CURVAS
'    AJUSTE DE CURVAS PELO METODOS DOS MMQ
'    (C) J RODOLFO S MARTINS
'    ESCOLA POLITÉCNICA - DEPARTAENTO DE ENGENHARIA HIDRAÚLICA
'    original: 01/05/1985       Rearranjado: 10/10/2016
    
    
    Set r = Application.InputBox(prompt:="Enter two columns source data:", Type:=8)
    Set s = Application.InputBox(prompt:="Enter top output cell:", Type:=8)
    N = Application.InputBox(prompt:="Enter Polyline degree:", Default:="2", Type:=1)
    
    M = r.Rows.count
    
    Xmax = -1000000#
    Xmin = 1000000#
    
    'cooca os cabeçalhos das curvas
    s(0, 1) = "Curva"
    s(0, 2) = "A1"
    s(0, 3) = "A2"
    s(0, 4) = "r2"
    s(10, 1) = "X"
    s(10, 2) = "1"
    s(10, 3) = "2"
    s(10, 4) = "3"
    s(10, 5) = "4"
    s(10, 6) = "5"
    s(10, 7) = "Pol"
    
AjusteLin:
    'ajuste linear 1.Y=A0+A1*X
    For i = 1 To M
        X(i) = r(i, 1)
        Y(i) = r(i, 2)
        'acha o maximo e se tem valores iguas a zero
        If X(i) > Xmax Then Xmax = X(i)
        If X(i) < Xmin Then Xmin = X(i)
        If X(i) = 0 Then TemzeroX = True
        If Y(i) = 0 Then TemzeroY = True
    Next i

    GoSub MMQ
    s(1, 1) = "1 Y=A1+A2*X"
    s(1, 2) = a1
    s(1, 3) = a2
    s(1, 4) = r2
    
    'cria a curva de plotagem
    dx = (Xmax - Xmin) / 100
    For i = 0 To 100
        s(11 + i, 1) = Xmin + i * dx
        s(11 + i, 2) = a1 + a2 * s(11 + i, 1)
    Next i
    
AjustePot:
    'ajuste potencial da curva Y=A1*X^A2
    If TemzeroX Or TemzeroY Then GoTo AjustaExp
    For i = 1 To M
        X(i) = Log(r(i, 1))
        Y(i) = Log(r(i, 2))
    Next i
    GoSub MMQ
    s(2, 1) = "2 Y=A1*X^A2"
    a1 = Exp(a1)
    s(2, 2) = a1
    s(2, 3) = a2
    s(2, 4) = r2

    For i = 0 To 100
        s(11 + i, 3) = a1 * s(11 + i, 1) ^ a2
    Next i

AjustaExp:
    '3 Y=A1*exp(A2*X)"
    If TemzeroY Then GoTo AjustaLog
    For i = 1 To M
        X(i) = (r(i, 1))
        Y(i) = Log(r(i, 2))
    Next i
    GoSub MMQ
    s(3, 1) = "3 Y=A1*exp(A2*X)"
    a1 = Exp(a1)
    s(3, 2) = a1
    s(3, 3) = a2
    s(3, 4) = r2

    For i = 0 To 100
        s(11 + i, 4) = a1 * Exp(a2 * s(11 + i, 1))
    Next i

AjustaGeom:
    '"4 Y=A1*A2^X"
    If TemzeroY Then GoTo AjustaLog
    For i = 1 To M
        X(i) = (r(i, 1))
        Y(i) = Log(r(i, 2))
    Next i

    GoSub MMQ
    s(4, 1) = "4 Y=A1*A2^X"
    a1 = Exp(a1)
    a2 = Exp(a2)
    s(4, 2) = (a1)
    s(4, 3) = (a2)
    s(4, 4) = r2

    For i = 0 To 100
        s(11 + i, 5) = a1 * a2 ^ s(11 + i, 1)
    Next i
    
    
AjustaLog:
    '5. Y=A1+A2*LN(X)"
    If TemzeroX Then GoTo AjustaPoli
    For i = 1 To M
        X(i) = Log(r(i, 1))
        Y(i) = (r(i, 2))
    Next i

    GoSub MMQ

    s(5, 1) = "5 Y=A1+A2*LN(X)"
    s(5, 2) = (a1)
    s(5, 3) = (a2)
    s(5, 4) = r2

    For i = 0 To 100
        s(11 + i, 6) = a1 + a2 * Log(s(11 + i, 1))
    Next i

    
AjustaPoli:
    'Faz o ajuste do Polinômio
    Dim A(50) As Single, B(50, 50) As Single, C(50) As Single
    Dim F As Single, Ro As Single

    GoSub ajustapol
    
    s(7, 1) = "Polinômio grau" & Str(N) & ":"
    For i = 1 To N + 1
        s(6, 1 + i) = "A" & Trim(Str(i))
        s(7, 1 + i) = A(i)
    Next i
    s(6, 1 + i) = "r2"
    s(7, 1 + N + 2) = r2
    
    For i = 0 To 100
        s(11 + i, 7) = 0
        For j = 1 To N + 1
            s(11 + i, 7) = s(11 + i, 7) + A(j) * s(11 + i, 1) ^ (j - 1)
        Next j
    Next i
    
    GoSub plota

    Exit Sub
    
    
    
'Subrotinas auxiliares
'ajusta o polinomio
ajustapol:
    For i = 1 To N + 1
        For j = 1 To N + 1
            B(i, j) = 0
            For k = 1 To M
                B(i, j) = B(i, j) + r(k, 1) ^ (i + j - 2)
            Next k
        Next j
    Next i
    For i = 1 To N + 1
        C(i) = 0
        For j = 1 To M
            C(i) = C(i) + r(j, 2) * (r(j, 1) ^ (i - 1))
        Next j
    Next i
    For i = 1 To N
        For j = i + 1 To N + 1
            F = B(j, i) / B(i, i)
            For k = i To N + 1
                B(j, k) = F * B(i, k) * (-1) + B(j, k)
            Next k
            C(j) = F * (-1) * C(i) + C(j)
        Next j
    Next i
    For i = N + 1 To 1 Step -1
        Ro = C(i)
        If i = N + 1 Then GoTo coef
        For j = N + 1 To i + 1 Step -1
            Ro = Ro - A(j) * B(i, j)
        Next j
coef:
        A(i) = Ro / B(i, i)
    Next i
    
' calcula a correlação do polinômio
    For i = 1 To M
        X(i) = 0
        For j = 1 To N + 1
            X(i) = X(i) + A(j) * r(i, 1) ^ (j - 1)
        Next j
        Y(i) = r(i, 2)
    Next i
    GoSub MMQ
    Return

'faz o ajuste linear
MMQ:
    sy = 0: sx = 0: sxy = 0: sx2 = 0: sy2 = 0
    For j = 1 To M
       sy = sy + Y(j): sx = sx + X(j): sxy = sxy + X(j) * Y(j): sx2 = sx2 + X(j) ^ 2: sy2 = sy2 + Y(j) ^ 2
    Next j
     a2 = (M * sxy - sx * sy) / (M * sx2 - sx * sx)
    a1 = (sy - a2 * sx) / M
    r2 = (M * sxy - sx * sy) ^ 2 / ((M * sx2 - sx ^ 2) * (M * sy2 - sy ^ 2))
    Return



'faz o grafico
plota:
    Dim nome As String, titulo As String
    nome = ActiveSheet.Name
    Charts.Add
    For i = ActiveChart.SeriesCollection.count To 1 Step -1
            ActiveChart.SeriesCollection(i).Delete
    Next i
    
    ActiveChart.ChartType = xlXYScatterLinesNoMarkers
    ActiveChart.Location Where:=xlLocationAsObject, Name:=nome
    
    With ActiveChart
        .SeriesCollection.NewSeries
        .SeriesCollection(1).Name = "Data"
        .SeriesCollection(1).XValues = Range(r(1, 1), r(M, 1)) '(valorX)
        .SeriesCollection(1).Values = Range(r(1, 2), r(M, 2)) '(valorY)
        .SeriesCollection(1).Select
        .SeriesCollection(1).Smooth = False
        .SeriesCollection(1).MarkerStyle = xlMarkerStyleDiamond
        .SeriesCollection(1).MarkerSize = 5
        .SeriesCollection(1).Format.Line.Weight = 0
        .SeriesCollection(1).Format.Line.ForeColor.RGB = QBColor(15)
       
        For i = 2 To 7
            titulo = "Curva " & Trim(Str(i - 1))
            .SeriesCollection.NewSeries
            .SeriesCollection(i).Name = titulo
            .SeriesCollection(i).XValues = Range(s(11, 1), s(111, 1)) '(valorX)
            .SeriesCollection(i).Values = Range(s(11, i), s(111, i)) '(valorY)
            .SeriesCollection(i).Select
            .SeriesCollection(i).Smooth = True
            .SeriesCollection(i).MarkerStyle = -4142
            .SeriesCollection(i).Format.Line.Weight = 1
            .SeriesCollection(i).Format.Line.ForeColor.RGB = QBColor(i - 1)
        Next i
               
        .Axes(xlCategory, xlPrimary).HasTitle = True
        .Axes(xlValue, xlPrimary).HasTitle = True
        .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "X"
        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Y"

        .HasLegend = False
        .PlotArea.Interior.ColorIndex = xlNone
    
        .ChartArea.width = 330
        .ChartArea.height = 165
        .ChartArea.Top = s.Top
        .ChartArea.Left = s.Left
        
        .PlotArea.Top = 15
        .PlotArea.Left = 15
        .PlotArea.width = 315
        .PlotArea.height = 135
    
    End With
    
    With ActiveChart.Axes(xlCategory)
        .MaximumScale = Xmax
        .MinimumScale = Xmin
        .HasMajorGridlines = False
        .HasMinorGridlines = False
        .MajorTickMark = xlInside
        .MinorTickMark = xlInside
        .TickLabelPosition = xlNextToAxis
    End With
    With ActiveChart.Axes(xlValue)
        .HasMajorGridlines = False
        .HasMinorGridlines = False
        .MajorTickMark = xlInside
        .MinorTickMark = xlInside
        .TickLabelPosition = xlNextToAxis
    End With

    With ActiveChart.TextBoxes.Add(90, 30, 65, 22)
                .Select
                .Text = "Total Series Points: " & Str(M) & Chr(10) & "Polynomial Power :" & Format(N, "###")
                .AutoSize = True
                .Font.Size = 9
    End With
    Return


End Sub