Một số hàm về ngày

Liên hệ QC

levanduyet

Hãy để gió cuốn đi.
Thành viên danh dự
Tham gia
30/5/06
Bài viết
1,798
Được thích
4,704
Giới tính
Nam
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:
Mã:
'*********************************
'   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
 
Một số hàm về ngày (tiếp theo)

Mã:
'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
 
Upvote 0
Web KT
Back
Top Bottom