PDA

View Full Version : Một số hàm về ngày



levanduyet
12-11-06, 09:19 AM
Và đây là module tôi sưu tập được, một số hàm về ngày (có một hàm tôi viết dùng cho việc kiểm tra khi nhập liệu vào Textbox:


'*********************************
' CAC HAM VE NGAY, THANG
'*********************************
Function DaysInMonth(ByVal serial_number As Date) As Integer
' Returns the number of days in the month for a date
Dim m As Integer, y As Integer
m = Month(serial_number)
y = Year(serial_number)
If m = 12 Then
m = 1
y = y + 1
Else
m = m + 1
End If
DaysInMonth = Day(DateSerial(y, m, 1) - 1)
End Function
Function MonthWeek(serial_number As Date) As Integer
' Returns the week of the month for a date
Dim FirstDay As Integer
' Check for valid date argument
If Not IsDate(serial_number) Then
MonthWeek = Evaluate("#VALUE")
Exit Function
End If
' Get first day of the month
FirstDay = Weekday(DateSerial(Year(serial_number), Month(serial_number), 1))
' Calculate the week number
MonthWeek = Application.RoundUp((FirstDay + Day(serial_number) - 1) / 7, 0)
End Function
Function WhichDay(weekdaynum As Integer, DOW As Integer, themonth As Integer, theyear) As Long
Dim i As Long, k As Integer, BadData As Boolean
BadData = False
If weekdaynum > 5 Or weekdaynum < 1 Then BadData = True
If DOW > 7 Or DOW < 1 Then BadData = True
If themonth > 12 Or themonth < 1 Then BadData = True
If BadData Then
WhichDay = Application.NA()
Exit Function
End If
For k = 1 To 7
If Weekday(DateSerial(theyear, themonth, k)) = DOW Then Exit For
Next k
Select Case weekdaynum
Case 1, 2, 3, 4: WhichDay = DateSerial(theyear, themonth, k) + ((weekdaynum - 1) * 7)
Case 5 'last one in the month
WhichDay = DateSerial(theyear, themonth, k) + ((weekdaynum - 1) * 7)
i = DateSerial(theyear, themonth, k)
If Month(WhichDay) <> Month(i) Then WhichDay = WhichDay - 7
End Select
End Function
Function MonthLetterToNumber(ByVal bthang As String) As Byte
Select Case bthang
Case "Jan"
MonthByNumber = 1
Case "Feb"
MonthByNumber = 2
Case "Mar"
MonthByNumber = 3
Case "Apr"
MonthByNumber = 4
Case "May"
MonthByNumber = 5
Case "Jun"
MonthByNumber = 6
Case "Jul"
MonthByNumber = 7
Case "Aug"
THANGSO = 8
Case "Sep"
MonthByNumber = 9
Case "Oct"
MonthByNumber = 10
Case "Nov"
MonthByNumber = 11
Case "Dec"
MonthByNumber = 12
Case Else
MonthByNumber = 0
End Select
End Function
Function MonthNumberToLetter(ByVal bthang As Byte) As String
Select Case bthang
Case 1
MONTHBYLETTER = "Jan"
Case 2
MONTHBYLETTER = "Feb"
Case 3
MONTHBYLETTER = "Mar"
Case 4
MONTHBYLETTER = "Apr"
Case 5
MONTHBYLETTER = "May"
Case 6
MONTHBYLETTER = "Jun"
Case 7
MONTHBYLETTER = "Jul"
Case 8
MONTHBYLETTER = "Aug"
Case 9
MONTHBYLETTER = "Sep"
Case 10
MONTHBYLETTER = "Oct"
Case 11
MONTHBYLETTER = "Nov"
Case 12
MONTHBYLETTER = "Dec"
Case Else
MONTHBYLETTER = "Error"
End Select
End Function
'*****************************************
'CAC HAM XU LY NGAY DAC BIET
'*****************************************
'Returns a specified date, displayed using the optional ftm date format string.
'Syntax:
'=XDATE(y,m,d,fmt)
'y A 4-digit year in the range 0100 to 9999
'm A month number (1-12)
'd A day number (1-31)
'fmt Optional. A date format string
'If the fmt argument is omitted, the date is displayed using the system's "short date" setting (as specified in the Windows Control Panel).
'If the m or d argument exceeds a valid number, it "rolls over" into the next year or month. For example, if you specify a month of 13, it is interpreted as January of the next year.
'This function returns a string, not a real date. Therefore, you cannot perform mathematical operations on the returned value using Excel's standard operators. You can, however, use the return value as an argument for other Extended Date functions.
'Examples:
'=XDATE(1776,7,4,"mmmm d, yyyy")
'Returns July 4, 1776.
'=XDATE(A1,B1,C1)
'Uses the year in A1, the month in B1, and the day in C1. The fmt argument is omitted, so it displays the date using the system "short date" format.
Function XDate(y, m, D, Optional fmt As String) As String
If IsMissing(fmt) Then fmt = "Short Date"
XDate = Format(DateSerial(y, m, D), fmt)
End Function
'Returns a date, incremented by a specified number of days, using the optional date format string. The days argument can be negative.
'Syntax:
'=XDATEADD(xdate1,days,fmt)
'xdate1 A date
'Days The number of days to add to xdate1
'fmt Optional. A date format string
'If the fmt argument is omitted, the date is displayed using the system's "short date" setting (as specified in the Windows Control Panel).
'This function returns a string, not a real date. Therefore, you cannot perform mathematical operations on the returned value using Excel's standard operators. You can, however, use the return value as an argument for other Extended Date functions.
'Examples:
'=XDATEADD(A1,7,"mmmm d, yyyy")
'Adds seven days to the date in cell A1 and displays the date using the specified format.
'=XDATEADD(A1,-365)
'Subtracts 365 days from the date in cell A1. The fmt argument is omitted, so it displays the date using the system "short date" format.
'=XDATEADD("July 4, 1776", 7,"mm-dd-yyyy")
'Returns 7 - 11 - 1776#
Function XDateAdd(xdate1, days, Optional fmt As String) As String
Dim TempDate As Date
If IsMissing(fmt) Then fmt = "Short Date"
xdate1 = RemoveDay(xdate1)
TempDate = DateValue(xdate1)
XDateAdd = Format(TempDate + days, fmt)
End Function
'Returns the number of days between two dates.
'Syntax:
'=XDATEDIF(xdate1,xdate2)
'xdate1 A date
'xdate2 A date
'Note: xdate2 is subtracted from xdate1. If xdate2 is later than xdate1, the result will be negative.
'Examples:
'=XDATEDIF("May 15, 1890","May 1, 1890")
'Returns 14, the number of days between the two dates.
'=XDATEDIF("May 1, 1890","May 15, 1890")
'Returns -14, a negative number of days because the second argument is later than the first argument.
'=XDATEDIF(A1,A2)
'Subtracts the date in cell A2 from the date in cell A1 and returns the result.
Function XDateIf(xdate1, xdate2) As Long
xdate1 = RemoveDay(xdate1)
xdate2 = RemoveDay(xdate2)
XDATEDIF = DateValue(xdate1) - DateValue(xdate2)
End Function
'Returns the number of full years between two dates. This function is useful for calculating ages.
'Syntax:
'=XDATEYEARDIF(xdate1,xdate2)
'xdate1 A date
'xdate2 A date
'Note: xdate2 is subtracted from xdate1. If xdate2 is later than xdate1, the result will be negative.
'Examples:
'=XDATEYEARDIF("May 1, 1890","April 30, 1891")
'Returns 0, because the difference between the two dates is not a full year.
'=XDATEYEARDIF("May 1, 1890","May 3, 1891")
'Returns 1, because the difference between the two dates is more than one year, but less than two years.
'=XDATEYEARDIF("Feb 16 1952",TODAY())
'Returns the age of someone born on February 16, 1952. This example uses Excel's TODAY function, which returns the current date.
Function XDATEYEARDIF(xdate1, xdate2) As Long
Dim YearDiff As Long
xdate1 = RemoveDay(xdate1)
xdate2 = RemoveDay(xdate2)
YearDiff = Year(xdate2) - Year(xdate1)
If DateSerial(Year(xdate1), Month(xdate2), Day(xdate2)) < CDate(xdate1) Then YearDiff = YearDiff - 1
XDATEYEARDIF = YearDiff
End Function
'Returns the year for a date.
'Syntax:
'=XDATEYEAR(xdate1)
'xdate1 A date
'Examples:
'=XDATEYEAR("May 15, 1890")
'Returns 1890#
'=XDATEYEAR(A1)
'Returns the year for the date in cell A1.
'=IF(XDATEYEAR(A1)<1900,TRUE,FALSE)
'Returns TRUE if the date in cell A1 is prior to the year 1900; otherwise it returns FALSE.
Function XDateYear(xdate1)
xdate1 = RemoveDay(xdate1)
XDateYear = Year(DateValue(xdate1))
End Function

levanduyet
12-11-06, 09:20 AM
'Returns an integer (between 1 and 12) that corresponds to the month for a date.
'Syntax:
'=XDATEMONTH(xdate1)
'xdate1 A date
'Examples:
'=XDATEMONTH("May 15, 1890")
'Returns 5 .
'=XDATEMONTH(A1)
'Returns an integer that corresponds to the month of the date in cell A1.
'=IF(XDATEMONTH(A1)=2,TRUE,FALSE)
'Returns TRUE if the date in cell A1 is in the month of February; otherwise, it returns FALSE.
Function XDateMonth(xdate1)
xdate1 = RemoveDay(xdate1)
XDateMonth = Month(DateValue(xdate1))
End Function

'Returns an integer that corresponds to the day for a date.
'Syntax:
'=XDATEDAY(xdate1)
'xdate1 A date
'Examples:
'=XDATEDAY("May 15, 1890")
'Returns 15 .
'=XDATEDAY(A1)
'Returns an integer that corresponds to the day of the date in cell A1.
Function XDateDay(xdate1)
XDateDay = Day(DateValue(xdate1))
End Function
'Returns an integer that corresponds to the day of the week for a date:
'1 = Sunday
'2 = Monday
'3 = Tuesday
'4 = Wednesday
'5 = Thursday
'6 = Friday
'7 = Saturday
'Syntax:
'=XDATEDOW(xdate1)
'xdate1 A date
'Examples:
'=XDATEDOW("May 15, 1890")
'Returns 5 (this date was a Thursday).
'=XDATEDOW(A1)
'Returns an integer that corresponds to the day of the week for the date in cell A1.
Function XDateDow(xdate1)
xdate1 = RemoveDay(xdate1)
XDateDow = Weekday(xdate1)
End Function

Private Function RemoveDay(xdate1)
' Remove day of week from string
Dim i As Integer
Dim Temp As String
Temp = xdate1
For i = 0 To 6 'Unabbreviated day names
Temp = Application.Substitute(Temp, Format(DateSerial(1900, 1, 0), "dddd"), "")
Next i
For i = 0 To 6 'Abbreviated day names
Temp = Application.Substitute(Temp, Format(DateSerial(1900, 1, 0), "ddd"), "")
Next i
RemoveDay = Temp
End Function
'****************************************
' Ham tinh ngay dua vao chuoi
' chua trong mot textbox
' Su dung Class clsString
'****************************************
Function DNgay(ByVal bTextbox As Object) As Variant
' Khi co loi se tra ve -1
Dim bchuoi As clsString
Dim bdem As Integer, bdai As Integer
Dim bDngay As Integer, bDthang As Integer, bDnam As Integer
Dim btemp, bngaytemp
On Error GoTo cuoi
Set bchuoi = New clsString
bchuoi.Text = bTextbox.Text
bchuoi.Delimiter = "/"
bdai = bchuoi.Length
' Tuc la neu chuoi rong thi Ngay la Ngay 1 cua Thang hien tai
If bdai = 0 Then
GoTo cuoi
End If
bdem = bchuoi.TokenCount
' Trong truong hop nguoi nhap chi nhap ngay vao TextBox
' Thi Thang la Thang hien tai; Ngay la Ngay hien tai
If bdem = 1 Then
bDnam = Year(Now)
bDthang = Month(Now)
bDngay = Val(bchuoi.TokenAt(1))
bngaytemp = "1" & "/" & bDthang & " /" & bDnam
If bDngay > DaysInMonth(bngaytemp) Or bDngay < 0 Then
GoTo cuoi
End If
' Trong truong hop nhap Ngay/Thang vao TextBox
ElseIf bdem = 2 Then
bDnam = Year(Now)
bDngay = Val(bchuoi.TokenAt(1))
bDthang = Val(bchuoi.TokenAt(2))
If (bDthang < 0 Or bDthang > 12) Then
GoTo cuoi
Else
bngaytemp = "1" & "/" & bDthang & " /" & bDnam
If bDngay > DaysInMonth(bngaytemp) Or bDngay < 0 Then
GoTo cuoi
End If
End If
' Trong truong hop nhap Ngay/Thang/Nam vao TextBox
ElseIf bdem = 3 Then
btemp = bchuoi.TokenAt(3)
bDngay = Val(bchuoi.TokenAt(1))
bDthang = Val(bchuoi.TokenAt(2))
blen = Len(bchuoi.TokenAt(3))
' Xet bien Nam
If blen = 2 Then
bDnam = "20" & bchuoi.TokenAt(3)
bDnam = Val(bDnam)
ElseIf blen = 4 Then
bDnam = bchuoi.TokenAt(3)
bDnam = Val(bDnam)
ElseIf blen = 1 Or blen = 3 Or blen > 4 Then
GoTo cuoi
End If
' Xet bien Thang
If bDthang > 12 Or bDthang < 0 Then
GoTo cuoi
Else
bDthang = bDthang
End If
' Xet bien Ngay
bngaytemp = "1" & "/" & bDthang & "/" & bDnam
If bDngay > DaysInMonth(bngaytemp) Or bDngay < 0 Then
GoTo cuoi
End If
End If
DNgay = XDate(bDnam, bDthang, bDngay, "dd/mm/yyyy")
Exit Function
cuoi:
' Tuc la khi co loi thi DNgay =-1
DNgay = -1

End Function

Hy vọng nó sẽ giúp cho các bạn phần nào trong lập trình VBA.

Lê Văn Duyệt