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 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109
| Public Sub FusionnerDates()
' Fusionne les 3 tableaux de pression
Dim Dates As New cDates
Dim wsh As Worksheet
Dim rng As Range
Dim cel As Range
Dim ctr As Long
Dim flgTrouvé As Boolean
Set wsh = Worksheets("Data & Results")
'Effacer les résultats
With wsh
.Range(.Cells(3, "H"), .Cells(.Rows.Count, "K")).ClearContents
End With
'Enregistrer les P1
With wsh
Set rng = .Range(.Range("A3"), .Range("A3").End(xlDown))
End With
For Each cel In rng.Cells
Dim DateRelevéP1 As New cDateRelevé
DateRelevéP1.Key = cel.Value
flgTrouvé = False
On Error GoTo ErrorHandler
flgTrouvé = Not Dates.Pressions(DateRelevéP1.Key) Is Nothing
On Error GoTo 0
If Not flgTrouvé Then
Dates.Pressions.Add DateRelevéP1, DateRelevéP1.Key
Dates.Pressions(DateRelevéP1.Key).P1 = cel.Offset(, 1).Value
Dates.Pressions(DateRelevéP1.Key).P2 = "#NA"
Dates.Pressions(DateRelevéP1.Key).P3 = "#NA"
End If
Set DateRelevéP1 = Nothing
Next cel
'Enregistrer les P2
With wsh
Set rng = .Range(.Range("C3"), .Range("C3").End(xlDown))
End With
For Each cel In rng.Cells
Dim DateRelevéP2 As New cDateRelevé
DateRelevéP2.Key = cel.Value
flgTrouvé = False
On Error GoTo ErrorHandler
flgTrouvé = Not Dates.Pressions(DateRelevéP2.Key) Is Nothing
On Error GoTo 0
If Not flgTrouvé Then
Dates.Pressions.Add DateRelevéP2, DateRelevéP2.Key
Dates.Pressions(DateRelevéP2.Key).P1 = "#NA"
Dates.Pressions(DateRelevéP2.Key).P2 = cel.Offset(, 1).Value
Dates.Pressions(DateRelevéP2.Key).P3 = "#NA"
Else
Dates.Pressions(DateRelevéP2.Key).P2 = cel.Offset(, 1).Value
End If
Set DateRelevéP2 = Nothing
Next cel
'Enregistrer les P3
With wsh
Set rng = .Range(.Range("E3"), .Range("E3").End(xlDown))
End With
For Each cel In rng.Cells
Dim DateRelevéP3 As New cDateRelevé
DateRelevéP3.Key = cel.Value
flgTrouvé = False
On Error GoTo ErrorHandler
flgTrouvé = Not Dates.Pressions(DateRelevéP3.Key) Is Nothing
On Error GoTo 0
If Not flgTrouvé Then
Dates.Pressions.Add DateRelevéP3, DateRelevéP3.Key
Dates.Pressions(DateRelevéP3.Key).P1 = "#NA"
Dates.Pressions(DateRelevéP3.Key).P2 = "#NA"
Dates.Pressions(DateRelevéP3.Key).P3 = cel.Offset(, 1).Value
Else
Dates.Pressions(DateRelevéP3.Key).P3 = cel.Offset(, 1).Value
End If
Set DateRelevéP3 = Nothing
Next cel
'Mettre à jour la fusion
Set cel = wsh.Range("H3")
ctr = 0
Dim DateRelevé As New cDateRelevé
For Each DateRelevé In Dates.Pressions
cel.Offset(ctr).Value = DateRelevé.Key
cel.Offset(ctr, 1).Value = DateRelevé.P1
cel.Offset(ctr, 2).Value = DateRelevé.P2
cel.Offset(ctr, 3).Value = DateRelevé.P3
ctr = ctr + 1
Next
Exit Sub
'Gestion d'erreur
ErrorHandler:
Select Case Err.Number
Case 5
If Err.Description = "Argument ou appel de procédure incorrect" Then
Resume Next
Else
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
Resume
End If
Case Else
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
Resume
End Select
End Sub |
Partager