Notifications
Clear all

Coordenograma vba

1 Posts
1 Usuários
0 Reactions
238 Visualizações
(@philippe)
Posts: 0
New Member
Topic starter
 

tenho esse código vba e preciso resolver um problema.
Preciso que as curvas parem nos pontos pretos e onde esta marcado em amarelo não seja plotado
, em outras palavras, as curvas devem se encontrar nas intersecções.
Utilizo o excel / vba 2010.
Alguém poderia me ajudar
?

Sub algoritmo_curvas2()

Dim pontos As Integer

' Otimização de Software
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

' Configurações comuns
pontos = 3000

' Calcula e armazena curvas
If Range("H8").Value <> "OFF" Then
Call calcular_curva("51", Range("H6").Value, Range("H8").Value, Range("H10").Value, Range("N8").Value, pontos, 20, 21) ' Colunas T e U
End If

If Range("H14").Value <> "OFF" Then
Call calcular_curva("51N", Range("H12").Value, Range("H14").Value, Range("H16").Value, Range("N14").Value, pontos, 22, 23) ' Colunas V e W
End If

If Range("H20").Value <> "OFF" Then
Call calcular_curva("51NS", Range("H18").Value, Range("H20").Value, Range("H22").Value, Range("N20").Value, pontos, 24, 25) ' Colunas X e Y
End If

If Range("Q26").Value <> "OFF" Then
Call calcular_curva("50", Range("H24").Value, "TD", Range("H26").Value, "TD", pontos, 26, 27) ' Colunas Z e AA
End If

If Range("Q30").Value <> "OFF" Then
Call calcular_curva("50N", Range("H28").Value, "TD", Range("H30").Value, "TD", pontos, 28, 29) ' Colunas AB e AC
End If

' Restaurar configurações do Excel
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True

End Sub

Sub calcular_curva(curva As String, ip As Double, norma As String, dial As Double, tipoCurva As String, pontos As Integer, colCorrente As Integer, colTempo As Integer)

Dim corrente(3000) As Double
Dim tempo(3000) As Double
Dim current As Double
Dim maximo As Double
Dim travel As Double
Dim i As Integer
Dim aux As Double

' Configurações iniciais
corrente(0) = ip
maximo = ip * 25
travel = maximo - corrente(0)

' Algoritmo de Comparação
For i = 0 To pontos - 1
' Calcular tempo para a curva
If norma = "TD" Then
' Se for TD, criar uma reta vertical
If i = 0 Then
tempo(i) = 50000000
Else
tempo(i) = dial
End If
Else
If corrente(i) = ip Then
current = corrente(i) * 1.00001
aux = curvas_tempo(ip, dial, norma, tipoCurva, current)
Else
aux = curvas_tempo(ip, dial, norma, tipoCurva, corrente(i))
If aux < 0.04 Then aux = 0.04
End If
If tempo(i) > aux And aux <> 0 Then
tempo(i) = aux
End If
End If

' Preparar próxima iteração
corrente(i + 1) = corrente(i) + travel / (pontos - 1)
tempo(i + 1) = 50000000

' Armazenar resultados na planilha
Sheets("BD").Cells(i + 2, colCorrente).Value = corrente(i)
Sheets("BD").Cells(i + 2, colTempo).Value = tempo(i)
Next i

End Sub

Function curvas_tempo(ByVal partida As Double, ByVal dial As Double, ByVal norma As String, ByVal caracteristica As String, ByVal corrente As Double) As Double

Dim alpha As Double, k As Double, A As Double, B As Double, C As Double, D As Double, E As Double, p As Double
Dim result As Double
Dim ratio As Double

If norma = "IEC" Then
Select Case caracteristica
Case "EI": k = 80: alpha = 2
Case "NI": k = 0.14: alpha = 0.02
Case "MI": k = 13.5: alpha = 1
Case "LI": k = 120: alpha = 1
Case "UI": k = 315.2: alpha = 2.5
End Select
ratio = corrente / partida
If ratio > 1 Then
On Error Resume Next
result = k * dial / ((ratio ^ alpha) - 1)
If Err.Number <> 0 Then
result = 0 ' Tratar qualquer erro de cálculo
Err.Clear
End If
On Error GoTo 0
Else
result = 0 ' Evitar divisão por zero ou resultados negativos
End If
curvas_tempo = result
Exit Function
ElseIf norma = "ANSI" Then
Select Case caracteristica
Case "EI": A = 0.0399: B = 0.2294: C = 0.5: D = 3.0094: E = 0.7222
Case "MI": A = 0.0615: B = 0.7989: C = 0.34: D = -0.284: E = 4.0505
Case "NI": A = 0.0274: B = 2.2614: C = 0.3: D = -4.1899: E = 9.1272
Case "MDI": A = 0.1735: B = 0.6791: C = 0.8: D = -0.08: E = 0.1271
End Select
ratio = corrente / partida
If ratio > C Then
On Error Resume Next
result = dial * (A + (B / (ratio - C)) + (D / ((ratio - C) ^ 2)) + (E / ((ratio - C) ^ 3)))
If Err.Number <> 0 Then
result = 0 ' Tratar qualquer erro de cálculo
Err.Clear
End If
On Error GoTo 0
Else
result = 0 ' Evitar divisão por zero ou resultados negativos
End If
curvas_tempo = result
Exit Function
ElseIf norma = "IEEE" Then
Select Case caracteristica
Case "EI": A = 0.0515: B = 0.114: p = 0.02
Case "MI": A = 19.61: B = 0.491: p = 2
Case "MDI": A = 28.2: B = 0.1217: p = 2
End Select
ratio = corrente / partida
If ratio > 1 Then
On Error Resume Next
result = dial * ((A / ((ratio ^ p) - 1)) + B)
If Err.Number <> 0 Then
result = 0 ' Tratar qualquer erro de cálculo
Err.Clear
End If
On Error GoTo 0
Else
result = 0 ' Evitar divisão por zero ou resultados negativos
End If
curvas_tempo = result
Exit Function
ElseIf norma = "KYLE" Then
Select Case caracteristica
Case "103": k = 2: alpha = 2.5: C = 0.015
Case "106": k = 4.5: alpha = 2.3: C = 0.012
Case "111": k = 5: alpha = 1.5: C = 0
Case "112": k = 9: alpha = 2: C = 0.02
Case "113": k = 16: alpha = 2.3: C = 0.018
Case "115": k = 60: alpha = 3.1: C = 0.01
Case "116": k = 20: alpha = 2: C = 0
Case "118": k = 25: alpha = 2.2: C = 0.015
Case "119": k = 20: alpha = 2: C = 0.45
Case "120": k = 30: alpha = 2: C = 0.09
Case "131": k = 0.65: alpha = 0.1: C = 0.38
Case "132": k = 60: alpha = 2.2: C = 0.01
Case "133": k = 43: alpha = 2: C = 0.04
Case "134": k = 50: alpha = 2.3: C = 0.4
Case "135": k = 30: alpha = 1.7: C = 0.5
Case "137": k = 40: alpha = 1.5: C = 0.1
Case "138": k = 42: alpha = 1.5: C = 0
Case "139": k = 40: alpha = 1.8: C = 0
Case "140": k = 80: alpha = 2: C = 1
Case "141": k = 0.05: alpha = 0.01: C = 10
Case "151": k = 180: alpha = 2.5: C = 0.45
Case "162": k = 80: alpha = 2.2: C = 0.02
Case "163": k = 20: alpha = 2: C = 0.01
Case "164": k = 250: alpha = 2.6: C = 0.02
Case "165": k = 800: alpha = 3.1: C = 0.04
Case "200": k = 100: alpha = 1.5: C = 0.25
Case "201": k = 800: alpha = 2.5: C = 0.5
Case "202": k = 300: alpha = 2: C = 0.02
End Select
ratio = corrente / partida
If ratio > 1 Then
On Error Resume Next
result = dial * ((k / ((ratio ^ alpha) - 1)) + C)
If Err.Number <> 0 Then
result = 0 ' Tratar qualquer erro de cálculo
Err.Clear
End If
On Error GoTo 0
Else
result = 0 ' Evitar divisão por zero ou resultados negativos
End If
curvas_tempo = result
Exit Function
End If

End Function

 
Postado : 01/08/2024 6:56 pm