Option Explicit
Function LapDS(TenDV As String, Rng As Range)
ReDim Arr(1 To 30, 1 To 1)
Dim sRng As Range, Cls As Range, Rg0 As Range, J As Long
Set sRng = Rng.Find(TenDV, , xlValues, xlWhole)
If Not sRng Is Nothing Then
Set Rg0 = sRng.Resize(Rng.Rows.Count)
For Each Cls In Rg0
If Cls.Value = "" Then Exit For
If Cls.Value = TenDV Then
J = 1 + J
Arr(J, 1) = Cls.Offset(, 1).Value
End If
Next Cls
Else
LapDS = "Nothing"
End If
LapDS = Arr()
End FunctionOption Explicit
Function TinhLuong(SoLg As Double, Cong As Double)
Dim TThuong As Double
TThuong = 10 ^ 3 * SoLg * Switch(SoLg <= 45, 0, SoLg <= 100, 10, SoLg <= 200, 18, SoLg > 200, 20)
If SoLg >= 45 And Cong >= 26 Then
TinhLuong = 2 * 10 ^ 6
Else
End If
TinhLuong = TinhLuong + TThuong
End FunctionMaNV |Ho Ten|...|Quà
NTX01|Lê Hòa|...|Áo mưa
NVH02|Ngô An|...|Mũ mềm
BXT00|Vũ Áng|...|Sửa
NTX01|Lê Hòa|...|Áo Sơ mi
NVH02|Ngô An|...|Găng tay
BXT00|Vũ Áng|...|KẹoTháng| Năm|Mã CTi|'Địa fương'
12 |2013|BGI056|Bặc liêu
08|2013|GHF12 |Cao Bằng
10|2013|MNM2Z |Đà Nẵng
02|2013|GGfKA2|Tp. HCMNội dung hàm người dùng sẽ như dưới đây:
Option Explicit: Option Base 1
Function LietKe(CSDL As Range, Tháng As Byte, Nam As Integer)
Dim Rws As Long, J As Long
Dim Rng As Range, sRng As Range
Rws = CSDL.Rows.Count
ReDim Arr(Rws, 4)
Set Rng = CSDL(1).Resize(Rws)
Set sRng = Rng.Find(Tháng, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
Set sRng = Range(sRng, Rng(1).Offset(Rws))
For Each Rng In sRng
With Rng
If .Value = Tháng And .Offset(, 1).Value = Nam Then
J = J + 1
Arr(J, 3) = .Offset(, 2).Value: Arr(J, 1) = Tháng
Arr(J, 4) = .Offset(, 3).Value: Arr(J, 2) = Nam
End If
End With
Next Rng
End If
LietKe = Arr()
End FunctionPublic Function DValue(Expr)
Char = Expr
Sent = Space(0)
ABC = "0123456789+-*/()." & Space(1)
XYZ = "0123456789" & Space(1)
For m = 2 To 3
Met = "m" & m
Temp = InStr(1, Char, Met)
Do While Temp > 0
If Temp > 0 Then
Char = Left(Char, Temp) & Mid(Char, Temp + 2)
End If
Temp = InStr(1, Char, Met)
Loop
Next
For i = 1 To Len(Char)
KyTu = Mid(Char, i, 1)
If InStr(1, ABC, KyTu) > 0 Then
Sent = Sent & KyTu
Else
Select Case KyTu
Case ":"
Left_ = Mid(Char, i - 1, 1)
Right_ = Mid(Char, i + 1, 1)
If InStr(1, XYZ, Right_) > 0 Then
Sent = Sent & "/"
End If
Case ","
Sent = Sent & "."
Case "%"
Sent = Sent & "/100"
Case "x", "X"
Left_ = Mid(Char, i - 1, 1)
Right_ = Mid(Char, i + 1, 1)
If InStr(1, XYZ, Right_) > 0 Then
Sent = Sent & "*"
End If
End Select
End If
Next
DValue = Eval(Sent)
End FunctionOption Explicit
Function MaxDay(TenHH As String, Rng As Range)
Dim sRng As Range
Dim Dat As Date, Tmp As Double
Dat = Application.WorksheetFunction.Min(Rng.Offset(, -1))
Set sRng = Rng.Find(TenHH, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
Set Rng = sRng.Resize(Rng.Rows.Count)
For Each sRng In Rng
If sRng.Offset(, -1).Value > Dat And sRng.Value = TenHH Then
Dat = sRng.Offset(, -1).Value
Tmp = sRng.Offset(, 1).Value
End If
Next sRng
End If
MaxDay = Tmp
End Function
Option Explicit
Function GCong(Rng As Range, Optional Loai As String = "B") As Double
Dim Cls As Range, VTr As Byte, Tmp As Double
For Each Cls In Rng
If Not IsNumeric(Cls.Value) Then
If Left(Cls.Value, 1) = Loai And Len(Cls.Value) > 1 Then
VTr = InStr(Cls.Value, ".")
If VTr < 1 Then
Tmp = Tmp + CDbl(Mid(Cls, 2, 5)) '?'
Else
Tmp = Tmp + _
TimeSerial(CInt(Mid(Cls.Value, 2, VTr - 2)), CInt(Mid(Cls.Value & "0", VTr + 1, 2)), 0)
End If
End If
End If
Next Cls
GCong = (Hour(Tmp) * 60 + Minute(Tmp)) / 480
End FunctionEm Có dãy mã số như dưới đây dùng để quản lí nhân viên trong 1 cơ quan;
MaNV | Mã ĐV
S0005|KHVT
S0007|TCKT
S0008|LĐTL
S0009|BGĐ
S????|KTh
Làm sao để em có thể tự động nhập được mã số tiếp theo sẽ là S0010,
Nhờ các anh chị giúp em. Trân trọng cảm ơnFunction MaNV(Ma As String) As String
MaNV = Left(Ma, 1) & Right("000" & CStr(CLng(Mid(Ma, 2, 5) + 1)), 4)
End Function STT| SBD |Ho Ten HV |Ngày Sinh|Fải thu
001|N1789|Hồ Văn Ca |21/04/94 |150.000
002|.. ..|Lê Hải Mĩ |04/11/94 |220.000
003|N2358|Lê Thị Hoa|14/09/93 |200.000
004|.. ..|Lê Thị Hoa|. . . . |240.000
005|.. ..|Lê Thị Hoa|02/08/93 | 0
006|N3250|Lê Văn Ba |25/04/93 |240.000
007|. ...|Lê Văn Ba |12/05/94 |150.000
008|N8971|Võ An Thu | . . . . |150.000Option Explicit
Function ChiaDoi(StrC As String, Optional Dau As Boolean = True) As String
Dim J As Integer, VT0 As Byte, Tmp As Byte
VT0 = Len(StrC) \ 2
If Mid(StrC, VT0, 1) = " " Then
ChiaDoi = GPE(StrC, VT0, Dau)
Else
For J = 1 To Len(StrC)
If Mid(StrC, VT0 - J, 1) = " " Then
ChiaDoi = GPE(StrC, VT0 - J, Dau)
Exit Function
ElseIf Mid(StrC, VT0 + J, 1) = " " Then
ChiaDoi = GPE(StrC, VT0 + J, Dau)
Exit Function
End If
Next J
End If
End Function[B]Function GPE(StrC As String, VTr As Byte, Optional Dau As Boolean = True)[/B]
If Dau Then
GPE = Left(StrC, VTr - 1)
Else
GPE = Mid(StrC, VTr + 1, Len(StrC))
End If
[B]End Function[/B] C [B]'Kết quả mong muốn'[/B]
Anh Tên 1 Số nhập Tên 2
1 Anh 1 Bình
Bình Ca 2 Dương
Em 3 Giương
Ca . . . .. . . .
2
Dương (Có nghĩa là:
'Nhập 1 số ở cột số nhập'
Em 'Thì ô bên trái & fải cùng dòng'
3 'sẽ hiện 2 tên trong cột [C],'
Giương 'mà ô bên trái chứa tên của dòng trên '
. . . . . 'còn ô kia là tên thuộc dòng dưới nó)'
. . .Function TimCap(Rng As Range, Num As Long, Optional Tren As Boolean = True)
Dim sRng As Range
Set sRng = Rng.Find(Num, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
If Tren Then
TimCap = sRng.End(xlUp).Value
Else
TimCap = sRng.End(xlDown).Value
End If
End If
End FunctionBưởi | 1 |đu đủ | 5 | Nho | 1 | | |
Nho | 2 |đu đủ | 1 |Xoài | 1 | | |
Nho | 2 |Bưởi | 1 |đu đủ | 1 | Táo | 1 |Option Explicit
Function Tach(StrC As String)
ReDim Arr(1 To 1, 1 To 100)
Const MN As String = "[": Const DN As String = "]"
Dim j As Integer, VTr As Integer, VT2 As Integer
StrC = Trim(StrC) & MN
Do
VTr = InStr(StrC, MN)
If VTr > 1 Then
j = j + 2
Arr(1, j - 1) = Trim(Left(StrC, VTr - 1))
VT2 = InStr(VTr, StrC, DN)
Arr(1, j) = Mid(StrC, VTr + 1, VT2 - VTr - 1)
StrC = Mid(StrC, VT2 + 2, 99)
Else
Exit Do
End If
Loop
Tach = Arr()
End FunctionLớp | HoTen |M1 | M2 | M3 | Tổng
6A1 |LT Lan |23 | 29| 37.5|10.14
6A1 |LV Lân |29 | 22| 31.5|20.45
6A1 |DT Vân |33 | 19| 27.6|15.14
6A1 |LV Cần |22 |22.1| 31 |26.45
.. . . .Lớp | HoTen |M1 | M2 | M3 | Tổng
6A1 |LV Cần |22 |22.1| 31 |26.45
6A2 |NT Lan |23 | 29| 37.5|20.14
6A5 |L Uyên |29 | 22| 31.5|24.45
7A1 |NT Vân |33 | 19| 27.6|25.14
.. . . .Option Explicit
Function DiemCN(MaLop As String, Rng As Range, cRit As Range)
ReDim Arr(1 To 1, 1 To 5)
Dim WF As Object, Sh As Worksheet, Cls As Range
Dim Max_ As Double
Set Sh = ThisWorkbook.Worksheets("Diem")
Set WF = Application.WorksheetFunction
Max_ = WF.DMax(Rng, Rng(6), cRit)
Arr(1, 5) = Max_
For Each Cls In Rng(6).Resize(Rng.Rows.Count)
If Cls.Value = Max_ And Cls.Offset(, -5).Value = MaLop Then
Arr(1, 1) = Cls.Offset(, -4): Arr(1, 2) = Cls.Offset(, -3)
Arr(1, 3) = Cls.Offset(, -2): Arr(1, 4) = Cls.Offset(, -1)
End If
Next Cls
DiemCN = Arr()
End FunctionOption Explicit
Function SoLonHon0(CSDL As Range, Ten As String)
Dim J As Long, Max_ As Double
Dim Rng As Range, Cls As Range
Set Rng = CSDL(1).Offset(, 1).Resize(CSDL.Rows.Count)
Max_ = Application.WorksheetFunction.Max(Rng) + 0.9
For Each Cls In CSDL
With Cls.Offset(, 1)
If Cls.Value = Ten And .Value < Max_ And .Value > 0 Then
Max_ = Cls.Offset(, 1).Value
End If
End With
Next Cls
SoLonHon0 = Max_
End FunctionCTi Họ Tên NgàySinh Loại SĐT 'Ngày'
CTi A Nguyễn Văn An 25/11/1976 VIP01 123456987 2
CTi B Trần Thành Bé 20/11/1967 VIP01 127496987 0
CTi A Ngô Thanh Ang 27/11/1956 VIP02 193456987 4
CTi B Huỳnh Văn Bay 26/11/1980 VIP01 127496987 3
CTi A Trần Lê Vy An 29/11/1984 VIP01 293456987 6
CTi B Nguyễn Thị Nữ 28/11/1985 VIP02 827496987 5Option Explicit
Function NgaySN(NSinh As Date)
Dim J As Byte, Dat As Date
For J = 1 To 7
Dat = Date + J
If SNTuan(NSinh) = SNTuan(Dat) Then
NgaySN = J: Exit Function
End If
Next J
End Function[b]
Function SNTuan(Dat As Date)[/b]
Const Chu As String = "123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
SNTuan = Mid(Chu, 10 + Month(Dat), 1) & Mid(Chu, Day(Dat), 1)
[b]End Function[/b]B C D E F G H I J K L M N O P Q R S T U V W X Y Z AA. . .. AZ
0 0 0 1 0 0 0 0 1 1 0 1 1 0 0 0 1 1 0 0 1 1 1 . . . . (Dòng 1)
9 0 0 8 1 2 8 1 . . . . . . . . . (Dòng 2: fần đặt tính thỏa điều kiện ghi bên dưới)Option Explicit
Function TraSo(Rg7 As Range)
Dim Cls As Range
Dim J As Byte, Tmp As Long
J = 1
For Each Cls In Rg7
Tmp = Tmp + Rg7(J) * 10 ^ (7 - J)
J = J + 1
Next Cls
If Tmp Mod 10000 = 1001 Or Tmp Mod 10000 = 1000 Then TraSo = 9
If Tmp Mod 1000 = 101 Or Tmp Mod 1000 = 100 Then TraSo = 3
If Tmp Mod 100 = 11 Then TraSo = 8
If Tmp Mod 100 = 10 Then TraSo = 1
End FunctionOption Explicit
Function SoTT(MaSo As String, Optional Dat As Date)
Const Alf As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Dim SoT1 As String, SoT3 As String, SoT2 As String, Tmp As String
Dim VTr As Byte
If Dat = 0 Then Dat = Date
Tmp = "-" & Right("0" & CStr(Day(Dat)), 2) & Right("0" & CStr(Month(Dat)), 2) & CStr(Year(Dat) Mod 100)
SoT3 = Mid(MaSo, 3, 1)
If SoT3 < "9" Then
SoTT = Left(MaSo, 2) & CStr(CByte(SoT3) + 1) & Tmp
Else
SoT2 = Mid(MaSo, 2, 1)
If SoT2 < "Z" Then
VTr = InStr(Alf, SoT2)
SoTT = Left(MaSo, 1) & Mid(Alf, VTr + 1, 1) & "0" & Tmp
Else
If Left(MaSo, 1) = "0" Then
SoTT = "1A0" & Tmp
Else
SoT1 = Left(MaSo, 1)
SoTT = CStr(CByte(SoT1) + 1) & "A0" & Tmp
End If
End If
End If
End FunctionOption Explicit
Public Function Sum_10(Arr As Range) As Double
Dim I As Long, J As Long, Tong As Double, Tmp As Double
J = Arr.Rows.Count
For I = J To 1 Step -1
Tmp = Tmp + Arr(I, 1).Value
Tong = Tong + Tmp / (J + 1 - I)
Next I
Sum_10 = Tong
End Function
