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
| 'procedure that updates the age of the patient in the column 'EDAD'
' j : position of the patient in the database
Sub agepatient(ByVal j As Integer)
Dim i As Integer
With ThisWorkbook.Worksheets("BASE TOTAL")
'if there is no data, we can't update
If .Cells(j, positionfndatabase).Value = "" Then
'MsgBox "Error with the patient number " & j & ". We don't know his date of birth. Please, deal with it manually at the end of the updating."
Else
Dim Date1 As String
Dim Date2 As String
'if date of birth = jj/mm/yyyy
If .Cells(j, positionfndatabase).Value Like "[0-9][0-9]/[0-9][0-9]/[0-9][0-9][0-9][0-9]" Then
'date of birth (in the format dd/mm/yyyy, as String)
Date1 = CStr(.Cells(j, positionfndatabase).Value)
'if date of birth = yyyy
ElseIf .Cells(j, positionfndatabase).Value Like "[0-9][0-9][0-9][0-9]" Then
'date of birth (in the format : 1/1/yyyy, as String)
Date1 = CStr("1/1/" & .Cells(j, positionfndatabase).Value)
'case of error
Else
MsgBox "Error with the patient number " & j & ". Please, deal with it manually at the end of the updating."
Exit Sub
End If
'date of today (in the format dd/mm/yyyy, as String)
Date2 = CStr(Format(Now(), "dd/mm/yyyy"))
'if the difference of year between the two dates is 0
If Left(age(Date1, Date2), 1) = "0" Then
'we copy 0
.Cells(j, positionedaddatabase).Value = 0
.Cells(j, positionedaddatabase).HorizontalAlignment = xlCenter
'if the difference of year between the two dates is strictly positive
ElseIf Left(age(Date1, Date2), 1) > 0 Then
'we copy the number of years
.Cells(j, positionedaddatabase).Value = Left(age(Date1, Date2), InStr(age(Date1, Date2), " year") - 1)
.Cells(j, positionedaddatabase).HorizontalAlignment = xlCenter
'case of error
Else
MsgBox "Error with the patient number " & j & ". Please, deal with it manually at the end of the updating."
End If
End If
End With
End Sub
'function that calculates the difference between 2 dates (format : "dd/mm/yyyy") and returns 'x years, y months and z days'
Function age(ByVal Date1 As Date, ByVal Date2 As Date) As String
Dim Y As Integer
Dim M As Integer
Dim D As Integer
Dim Temp1 As Date
Temp1 = DateSerial(Year(Date2), Month(Date1), Day(Date1))
Y = Year(Date2) - Year(Date1) + (Temp1 > Date2)
M = Month(Date2) - Month(Date1) - (12 * (Temp1 > Date2))
D = Day(Date2) - Day(Date1)
If D < 0 Then
M = M - 1
D = Day(DateSerial(Year(Date2), Month(Date2) + 1, 0)) + D + 1
End If
age = Y & " years " & M & " months " & D & " days"
End Function |
