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
| Private Sub CommandButton2_Click()
Dim Shd As Worksheet, Sht As Worksheet
Dim X As Range, c As Range
Dim Mx As Double, Mn As Double, H1 As Double, H2 As Double
Dim LastLig As Long, i As Long
Dim LastCol As Integer
Application.ScreenUpdating = False
'-----------------------------------------------------Préparation Feuille résultat analyse--------
On Error Resume Next
Set Sht = Worksheets("Temp")
On Error GoTo 0
If Sht Is Nothing Then
Set Sht = Sheets.Add(After:=Worksheets("Data"))
Sht.Name = "Temp"
Else
Sht.UsedRange.Clear
End If
With Sht.Range("A1:G1")
.Value = Array("t", "Max - 2°", "Min + 2°", "Hhaut", "Hbas", "Delta h", "Rapp h")
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
'--------------------------------------------------------------------------------------------------
Set Shd = Worksheets("Data")
With Shd
LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row 'Dernière ligne remplie de la colonne A
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column 'Dernière colonne remplie de la ligne 1
For i = 3 To LastLig 'On parcours les plages lignes par ligne
Set X = .Range(.Cells(i, 2), .Cells(i, LastCol))
Mx = Application.Max(X) - 2 'Mx: maximum de la ligne +2
Mn = Application.Min(X) + 2 'Mn: Minimum de la ligne +2
Set c = Recherche(X, Mx) 'On récupère dans c la cellule juste supérieur à Mx (valeur w), la cellule juste inférieur à Mx (valeur z)
H1 = Reg(c, Mx) 'On fait une regression linéaire entre w et z
Set c = Recherche(X, Mn) 'De même pour Mn
H2 = Reg(c, Mn)
Set X = Nothing
Set c = Nothing
Sht.Range("A" & i - 1).Value = .Range("A" & i).Value 'On écrit le résultat dans feuille Temp
Sht.Range("B" & i - 1).Value = Mx
Sht.Range("C" & i - 1).Value = Mn
Sht.Range("D" & i - 1).Value = H1
Sht.Range("E" & i - 1).Value = H2
Sht.Range("F" & i - 1).Value = H1 - H2
Sht.Range("G" & i - 1).Value = (H1 - H2) / 0.785
Next i
End With
End Sub
'Fonction de recherche de la cellule dont la valeur est juste supérieur à la valeur de recherche T
Private Function Recherche(Rng As Range, ByVal T As Double) As Range
Dim c As Range
Dim i As Integer
For Each c In Rng
i = i + 1
If c.Value <= T And i > 1 Then Exit For
Next c
Set Recherche = c.Offset(0, -1)
End Function
'Fonction de regression linéaire entre 2 points (éqution d'une droite)
Private Function Reg(Rng1 As Range, ByVal T As Double) As Double
Dim x1 As Double, x2 As Double, y1 As Double, y2 As Double
Dim Rng2 As Range
Set Rng2 = Rng1.Offset(0, 1)
x1 = Rng1.Value
x2 = Rng2.Value
y1 = Rng1.Offset(1 - Rng1.Row, 0).Value
y2 = Rng2.Offset(1 - Rng2.Row, 0).Value
Set Rng2 = Nothing
If Abs(x1 - x2) < 0.0001 Then
Reg = y1
Else
Reg = ((y2 - y1) / (x2 - x1)) * (T - x1) + y1
End If
End Function |
Obtenir des hauteurs a partir d'une base de donnees de courbes
Répondre avec citation
)
Partager