Học và luyện lập trình Visual Basic For Applications (VBA) với thầy Nguyễn Thế Anh, Cty CP Giá Xây Dựng, người truyền nhiệt huyết cho các kỹ sư xây dựng tự động hóa các công việc buồn tẻ, nhàm chán.
Bước khởi đầu rất quan trọng, nếu trơn tru và suôn sẻ thì sẽ tạo hứng khởi, ngược lại gặp lỗi không xử lý được thì bắt đầu nản. Thường chỉ cần có người dìu dắt được qua bước bỡ ngỡ ban đầu là sẽ ngon. Với các video và code mẫu dưới đây sẽ giúp bạn ra nhập thế giới lập trình VBA dễ dàng
# I. CÁC HÀM DỰNG
Hàm dựng là hàm Excel không có sẵn, do anh em mình dùng Excel rồi dựng ra (viết code, lập trình) theo yêu cầu riêng.
# 1. Hàm VND
Video này sẽ hướng dẫn bạn thêm đoạn mã VBA hàm VND vào file Excel để đọc số tiền thành bằng chữ. Hàm VND hữu ích cho các bạn kinh tế, tài chính, dự toán... những ai hay phải làm việc với bảng tính tiền và phải đọc số tiền thành bằng chữ.
Bạn copy code hàm VND sau để sử dụng:
Function vnd(conso) As String
Dim nSheet As String
nSheet = ActiveSheet.Name
If nSheet <> "VLHT XD" And nSheet <> "VLHT TB" Then
s09 = Array("", " m" & ChrW$(7897) & "t", " hai", " ba", " b" & ChrW$(7889) & "n", " n" & ChrW(259) & "m", " s" & ChrW$(225) & "u", " b" & ChrW$(7843) & "y", " t" & ChrW$(225) & "m", " ch" & ChrW$(237) & "n")
lop3 = Array("", " tri" & ChrW$(7879) & "u", " ngh" & ChrW$(236) & "n", " t" & ChrW$(7927))
If Trim(conso) = "" Then
vnd = ""
ElseIf IsNumeric(conso) = True Then
If conso < 0 Then dau = ChrW$(226) & "m " Else dau = ""
conso = Application.WorksheetFunction.Round(Abs(conso), 0)
conso = " " & conso
conso = Replace(conso, ",", "", 1)
vt = InStr(1, conso, "E")
If vt > 0 Then
sonhan = Val(Mid(conso, vt + 1))
conso = Trim(Mid(conso, 2, vt - 2))
conso = conso & String(sonhan - Len(conso) + 1, "0")
End If
conso = Trim(conso)
sochuso = Len(conso) Mod 9
If sochuso > 0 Then conso = String(9 - (sochuso Mod 12), "0") & conso
docso = ""
i = 1
LOP = 1
Do
n1 = Mid(conso, i, 1)
n2 = Mid(conso, i + 1, 1)
n3 = Mid(conso, i + 2, 1)
baso = Mid(conso, i, 3)
i = i + 3
If n1 & n2 & n3 = "000" Then
If docso <> "" And LOP = 3 And Len(conso) - i > 2 Then s123 = " t" & ChrW$(7927) Else s123 = ""
Else
If n1 = 0 Then
If docso = "" Then s1 = "" Else s1 = " kh" & ChrW$(244) & "ng tr" & ChrW$(259) & "m"
Else
s1 = s09(n1) & " tr" & ChrW$(259) & "m"
End If
If n2 = 0 Then
If s1 = "" Or n3 = 0 Then
s2 = ""
Else
s2 = " linh"
End If
Else
If n2 = 1 Then s2 = " m" & ChrW$(432) & ChrW$(7901) & "i" Else s2 = s09(n2) & " m" & ChrW$(432) & ChrW$(417) & "i"
End If
If n3 = 1 Then
If n2 = 1 Or n2 = 0 Then S3 = " m" & ChrW$(7897) & "t" Else S3 = " m" & ChrW$(7889) & "t"
ElseIf n3 = 5 And n2 <> 0 Then
S3 = " l" & ChrW$(259) & "m"
ElseIf n3 = 4 And n2 <> 1 And n2 <> 4 And n1 = 4 Then S3 = " t" & ChrW$(432)
Else
S3 = s09(n3)
End If
If i > Len(conso) Then
s123 = s1 & s2 & S3
Else
s123 = s1 & s2 & S3 & lop3(LOP)
End If
End If
LOP = LOP + 1
If LOP > 3 Then LOP = 1
If docso <> "" And s123 <> "" Then
docso = docso & ","
End If
docso = docso & s123
If i > Len(conso) Then Exit Do
Loop
vnd = UCase(Left(dau & Trim(docso), 1)) & Mid(dau & Trim(docso), 2) & " " & ChrW$(273) & ChrW$(7891) & "ng."
If Left(vnd, 2) = "T" & ChrW(432) Then
vnd = "B" & ChrW(7889) & "n" & Right(vnd, (Len(vnd) - 2))
End If
Else
vnd = conso
End If
End If
End Function
# 2. Hàm USD
Tương tự hàm VND, nhưng hàm USD đọc số tiền Đô la thành chữ tiếng Anh. Bạn copy đoạn mã VBA thực hiện hàm USD vào file Excel và chạy.
Function USD(Tien)
If Tien = 0 Then
Toread = "None"
Else
SP = Space(1)
RR = Space(0)
Donvi = RR: Hchuc = RR: Khung = RR
Donvi = Donvi + "one two three four "
Donvi = Donvi + "five six seven eight "
Donvi = Donvi + "nine ten eleven twelve "
Donvi = Donvi + "thirteen fourteen fifteen sixteen "
Donvi = Donvi + "seventeeneighteen nineteen "
Hchuc = Hchuc + "twenty thirty forty fifty "
Hchuc = Hchuc + "sixty seventy eighty ninety "
Khung = Khung + "billion milion thousand dollars cents "
If Tien < 0 Then
Toread = "Minus "
Else
Toread = RR
End If
Chuoi = Format(Abs(Tien), "############.00")
Chuoi = Right(Space(12) + Chuoi, 15)
For i = 1 To 5
NHOM = Mid(Chuoi, i * 3 - 2, 3)
If NHOM <> Space(3) Then
Select Case NHOM
Case "000"
If i = 4 And Abs(Tien) > 1 Then
Word = "dollars "
Else
Word = RR
End If
Case ".00"
Word = "only"
Case Else
X = Val(Left(NHOM, 1))
Y = Val(Mid(NHOM, 2, 1))
Z = Val(Right(NHOM, 1))
W = Val(Right(NHOM, 2))
If X = 0 Then
Word = RR
Else
Word = Trim(Mid(Donvi, X * 9 - 8, 9)) + " hundred "
If W > 0 And W < 21 Then
Word = Word + "and "
End If
End If
If i = 5 And Abs(Tien) > 1 Then
Word = "and " + Word
End If
If W < 20 And W > 0 Then
Word = Word + Trim(Mid(Donvi, W * 9 - 8, 9)) + SP
Else
If W >= 20 Then
Word = Word + Trim(Mid(Hchuc, (Y - 1) * 9 - 8, 9)) + SP
If Z > 0 Then
Word = Word + Trim(Mid(Donvi, Z * 9 - 8, 9)) + SP
End If
End If
End If
Word = Word + Trim(Mid(Khung, i * 9 - 8, 9)) + SP
End Select
Toread = Toread + Word
End If
Next i
End If
USD = Trim(UCase(Left(Toread, 1)) + Mid(Toread, 2))
If Right(USD, 9) = "and cents" Then
USD = Left(USD, Len(USD) - 10)
End If
End Function
# 3. Hàm Khối lượng Kl
Hàm Kl giúp tính toán khối lượng công tác xây dựng. Ứng dụng trong các file phần mềm GXD như: phần mềm Dự toán GXD, Dự thầu GXD, Quyết toán GXD, Quản lý chất lượng GXD và file Excel bất kỳ.
Public Function kl(strText As String)
If Right(strText, 1) = " " Then
kl = "0"
Else
strText = Replace(strText, "m2", "")
strText = Replace(strText, "m3", "")
strText = Replace(strText, "M2", "")
strText = Replace(strText, "M3", "")
strText = Replace(strText, ",", ".")
If vitri(" ", strText) < Len(strText) And vitri(" ", strText) > 1 Then
strText = Right(strText, Len(strText) - vitri(" ", strText))
'Else
End If
kl = ""
For i = 1 To Len(strText)
kytu = Mid(strText, i, 1)
ktdb = Mid(strText, i, 4)
If kytu = "0" Or kytu = "1" Or kytu = "2" Or kytu = "3" Or kytu = "4" Or kytu = "5" Or kytu = "6" Or kytu = "7" _
Or kytu = "8" Or kytu = "9" Or kytu = "+" Or kytu = "-" Or kytu = "*" Or kytu = "/" Or kytu = "^" Or kytu = "." _
Or kytu = "," Or kytu = "(" Or kytu = ")" Or kytu = "%" Or kytu = "x" Or kytu = "X" Or ktdb = "sqrt" Or ktdb = "Sqrt" Or ktdb = "SQRT" Then
If ktdb = "sqrt" Or ktdb = "Sqrt" Or ktdb = "SQRT" Then
kytu = "sqrt"
End If
If kytu = "x" Or kytu = "X" Then
kytu = "*"
End If
kl = kl & kytu
End If
Next
If kl = "" Then
kl = 0
End If
End If
kl = kl + "+0"
If IsError(Evaluate(kl)) Then
kl = "0"
Else
kl = Evaluate(kl)
If kl = 0 Then
kl = "0"
End If
End If
End Function
# 4. Hàm dichthuat Google Translate
Hàm googletranslate giúp bạn dịch nhanh các hồ sơ dự toán, dự thầu, thanh quyết toán, quản lý chất lượng... Lập hàm và sao chép roạt ra hàng loạt, dữ liệu dịch vào luôn bảng tính. Dịch dựa vào Google Translate nên sau khi có dữ liệu bạn cần biên tập, chỉnh sửa thêm ngữ nghĩa.
Function dichthuat(sText As String, FromLang, ToLang)
Dim p1, p2, URL, resp
Const DIV_RESULT$ = "<div class=""result-container"">"
Const URL_TEMPLATE$ = "https://translate.google.com/m?hl=[from]&sl=[from]&tl=[to]&ie=UTF-8&prev=_m&q="
URL = URL_TEMPLATE & WorksheetFunction.EncodeURL(sText)
URL = Replace(URL, "[to]", ToLang)
URL = Replace(URL, "[from]", FromLang)
resp = WorksheetFunction.WebService(URL)
p1 = InStr(resp, DIV_RESULT)
If p1 Then
p1 = p1 + Len(DIV_RESULT)
p2 = InStr(p1, resp, "</div>")
dichthuat = Mid$(resp, p1, p2 - p1)
End If
End Function
# II. CÁC CHỨC NĂNG
# 1. Hiển thị tất cả sheet ẩn
Unhide all Hidden Worksheets. Đoạn code VBA này hiển thị tất cả các sheet đang ẩn thay vì bạn phải unhide từng sheet.
Sub UnhideAllWorksheet()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Visible = xlSheetVisible
Next ws
End Sub
# 2. Ẩn tất cả ngoại trừ sheet hiện hành
Hide all but the Active Worksheet. Đoạn code VBA này ẩn tất cả các sheet ngoại trừ sheet đang hoạt động (sheet hiện hành). Không cần code, với Excel bạn kích vào sheet đầu và giữ Shift kích vào sheet cuối rồi kích phải vào tên sheet bất kỳ chọn Hide.
Sub HideWorksheet()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> ThisWorkbook.ActiveSheet.Name Then
ws.Visible = xlSheetHidden
End If
Next ws
End Sub
# 3. Tạo mục lục link tới tất cả các sheet
Create links to all sheets. Đoạn mã VBA này sẽ nhanh chóng lấy tên tất cả các sheet trong file và gắn link vào tạo ra 1 Mục lục tiện lợi để bạn truy xuất tới các sheet dễ dàng và nhanh chóng.
Sub CreateLinksToAllSheets()
Dim sh As Worksheet
Dim cell As Range
Dim x As Integer
x = 1
For Each sh In ActiveWorkbook.Worksheets
If ActiveSheet.Name <> sh.Name Then
Range(Cells(ActiveCell.Row, ActiveCell.Column - 1).Address).Value = x
ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
"'" & sh.Name & "'" & "!A1", TextToDisplay:=sh.Name
ActiveCell.Offset(1, 0).Select
x = x + 1
End If
Next sh
End Sub
# 4. Xóa các style rác
Delete all style. Nếu bạn thấy file Excel chạy ì ạch, cứ như là bấm 1 lệnh rồi đi pha 1 ly cà phê rồi quay lại mới chạy xong. Thì đoạn code VBA nhỏ sau giúp file của bạn nhẹ và chạy nhanh hơn. Đoạn code VBA này được lập trình để xóa nhanh tất cả các Style rác, không dùng đến trong file nhưng lại gây nặng file và chạy chậm.
Sub StyleKill()
Dim styT As Style
Dim intRet As Integer
On Error Resume Next
For Each styT In ActiveWorkbook.Styles
If Not styT.BuiltIn Then
If styT.Name <> "1" Then styT.Delete
End If
Next styT
End Sub
# 5. Sao chép siêu liên kết giữa các ô trong Excel
Khi nâng cấp file phần mềm QLTL GXD, QLDA GXD, GSXD GXD cần copy siêu liên kết (Hyperlink) từ các vùng ô ở cột này sang cột khác tôi đã dùng Macro dưới đây, rất nhanh và hiệu quả. Bạn có thể sử dụng cho nhiều tình huống khác khi bạn muốn. Một điều rất hay nữa là qua Macro đơn giản này bạn biết cách tạo ra hộp thoại với tiêu đề, thông điệp và ô Input.
Sub CopyHyperlinks()
'Uodateby Extendoffice
Dim xSRg As Range
Dim xDRg As Range
Dim I As Integer
Dim xAddress As String
On Error Resume Next
xAddress = ActiveWindow.RangeSelection.Address
Set xSRg = Application.InputBox("Hay chon vung ban muon copy hyperlinks:", "GXD sao chep Hyperlink", xAddress, , , , , 8)
If xSRg Is Nothing Then Exit Sub
Set xDRg = Application.InputBox("Hay chon vung ban muon dan hyperlinks:", "GXD sao chep Hyperlink", , , , , , 8)
If xDRg Is Nothing Then Exit Sub
Set xDRg = xDRg(1)
For I = 1 To xSRg.Count
If xSRg(I) <> "" And xDRg.Offset(I - 1) <> "" Then
If xSRg(I).Hyperlinks.Count = 1 Then
xDRg(I).Hyperlinks.Add xDRg(I), xSRg(I).Hyperlinks(1).Address
End If
End If
Next
End Sub
# 6. Thiết lập môi trường lập trình VBA Excel thuận lợi nhất cho người mới
# 7. Nhập cuộc lập trình VBA Excel đơn giản và dễ dàng nhất cho người mới bắt đầu
# 8. Fully Automated Data Entry User Form in Excel
Một video kèm theo tài liệu hướng dẫn bạn từng bước tạo form nhập dữ liệu trong Excel với hộp thoại, nút bấm và các ô nhập liệu khá là đẹp. Đây là 1 dự án nho nhỏ đáng để bạn thực hành theo, để có thể áp dụng vào nhiều công việc phải nhập liệu.
# 9. Xóa các sheet ẩn
Có lúc file Excel của bạn có chứa nhiều Sheet ẩn mà không cần đến nữa bạn có thể xóa nhanh những Sheet ẩn bằng đoạn code dưới đây. Hoặc bạn muốn xóa nhiều sheet chỉ việc ẩn chúng đi rồi dùng đoạn code dưới, việc ẩn đi như là để đánh dấu rằng các sheet này cần xóa đi.
Sub Delete_Hidden_Sheets()
j = 1
While j <= Worksheets.Count
If Not Worksheets(j).Visible Then
Worksheets(j).Delete
Else
j = j + 1
End If
Wend
End Sub
# 10. Remove mật khẩu khóa VBA
Có lúc file Excel của bạn bị quên, không nhớ mật khẩu, tôi sưu tầm được đoạn code sau do 1 bạn người Việt Nam tạo ra, sau đó 1 bạn người Ấn Độ làm video hướng dẫn.
Cách sử dụng: Bước 1. Mở Excel sẽ mở ra Book 1, bạn Alt+F11 để mở VBA Editor Bước 2. Insert / Module để thêm 1 module mới Bước 3. Copy và dán code bên dưới vào module nói trên Bước 4. Mở file bạn muốn gỡ mật khẩu Bước 5. Để trỏ text ở chỗ đoạn code Sub UnprotectVBA() dưới cùng rồi Run Bước 6. Kiểm tra lại Module bị khóa đã mở, đổi lại mật khẩu của bạn rồi lưu lại
Xin lưu ý: 1. Chỉ dùng code này để gỡ mật khẩu file của bạn, không sử dụng để phá file và công việc của tổ chức, cá nhân khác, cũng như các hành vi phạm pháp luật. 2. Code này test chạy trên Win + Office 64bit
Private Const PAGE_EXECUTE_READWRITE = &H40
Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As LongPtr, Source As LongPtr, ByVal Length As LongPtr)
Private Declare PtrSafe Function VirtualProtect Lib "kernel32" (lpAddress As LongPtr, _
ByVal dwSize As LongPtr, ByVal flNewProtect As LongPtr, lpflOldProtect As LongPtr) As LongPtr
Private Declare PtrSafe Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, _
ByVal lpProcName As String) As LongPtr
Private Declare PtrSafe Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As LongPtr, _
ByVal pTemplateName As LongPtr, ByVal hWndParent As LongPtr, _
ByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer
Dim HookBytes(0 To 11) As Byte
Dim OriginBytes(0 To 11) As Byte
Dim pFunc As LongPtr
Dim Flag As Boolean
Private Function GetPtr(ByVal Value As LongPtr) As LongPtr
GetPtr = Value
End Function
Public Sub RecoverBytes()
If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 12
End Sub
Public Function Hook() As Boolean
Dim TmpBytes(0 To 11) As Byte
Dim p As LongPtr, osi As Byte
Dim OriginProtect As LongPtr
Hook = False
#If Win64 Then
osi = 1
#Else
osi = 0
#End If
pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA")
If VirtualProtect(ByVal pFunc, 12, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then
MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, osi + 1
If TmpBytes(osi) <> &HB8 Then
MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 12
p = GetPtr(AddressOf MyDialogBoxParam)
If osi Then HookBytes(0) = &H48
HookBytes(osi) = &HB8
osi = osi + 1
MoveMemory ByVal VarPtr(HookBytes(osi)), ByVal VarPtr(p), 4 * osi
HookBytes(osi + 4 * osi) = &HFF
HookBytes(osi + 4 * osi + 1) = &HE0
MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 12
Flag = True
Hook = True
End If
End If
End Function
Private Function MyDialogBoxParam(ByVal hInstance As LongPtr, _
ByVal pTemplateName As LongPtr, ByVal hWndParent As LongPtr, _
ByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer
If pTemplateName = 4070 Then
MyDialogBoxParam = 1
Else
RecoverBytes
MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, _
hWndParent, lpDialogFunc, dwInitParam)
Hook
End If
End Function
Sub UnprotectVBA()
If Hook Then
MsgBox "VBA Project is unprotected!", vbInformation, "VBA Unlocked"
End If
End Sub
# 11. Xóa bớt Name rác do virus tạo ra
Một bạn bên tư vấn TEDI gửi cho tôi 1 file Excel kêu lập bằng phần mềm Dự toán GXD, gửi cho chủ đầu tư và bên thẩm định/thẩm tra không mở được. Tôi kiểm tra file thì là do máy bạn đó nhiễm virus Macro, tạo đầy ra Name rác nên nặng, gửi cho những máy yếu không mở được hoặc chạy rất lâu, sửa gì thì file lag giật. Bạn có thể kiểm tra bằng cách mở file đó lên, chọn Formulas / Name Manager, trong hộp Name Manager mở ra sẽ thấy đầy các Name rác linh tinh. Về lý thuyết thì bạn sẽ phải tìm xóa các Name rác đi, giữ lại các Name tốt dùng cho bảng tính và phần mềm GXD. Nhưng nếu xóa từng cái một thì lâu lắm. Tôi viết ra đoạn code sau giúp bạn đó xóa bớt các Name rác, không xóa được 100%, nhưng đã nhẹ và nhanh hơn rất nhiều, tự nhiên làm việc thấy nhẹ nhàng hẳn.
Thực hiện: Bạn mở file Excel, Alt+F11 dán code sau vào và chạy, Save ra file khác đề phòng hỏng file gốc nhé.
Sub DeleteInvalidAndExternalNames()
Dim nm As Name
Dim InvalidCount As Long
Dim DeletedNames As String
Dim RefString As String
InvalidCount = 0
DeletedNames = ""
On Error Resume Next ' Bỏ qua lỗi khi truy cập Name
' Lặp qua tất cả các Names trong workbook
For Each nm In ThisWorkbook.Names
RefString = nm.RefersTo
' Kiểm tra các điều kiện để xóa Name
If RefString = "" Then
' Xóa Name nếu rỗng
nm.Delete
DeletedNames = DeletedNames & nm.Name & vbNewLine
InvalidCount = InvalidCount + 1
ElseIf InStr(1, RefString, "[") > 0 Then
' Xóa Name tham chiếu đến file bên ngoài (có dấu ngoặc vuông [])
nm.Delete
DeletedNames = DeletedNames & nm.Name & vbNewLine
InvalidCount = InvalidCount + 1
ElseIf IsError(Evaluate(RefString)) Then
' Xóa Name bị lỗi
nm.Delete
DeletedNames = DeletedNames & nm.Name & vbNewLine
InvalidCount = InvalidCount + 1
End If
Next nm
On Error GoTo 0 ' Bật lại thông báo lỗi
' Thông báo kết quả
If InvalidCount > 0 Then
MsgBox InvalidCount & " tên đã bị xóa:" & vbNewLine & DeletedNames, vbInformation, "Kết quả"
Else
MsgBox "Không tìm thấy tên rác, tên lỗi hoặc tham chiếu link bên ngoài nào.", vbInformation, "Kết quả"
End If
End Sub
- Hãy truy cập Kênh video bấm Sucrible (đăng ký kênh) để có bài giảng mới youtube sẽ gửi thông báo cho bạn nhé.
- Nếu bạn gặp vướng mắc gì hãy gửi lên group facebook mình và nhiều bạn nhiệt tình sẽ chỉ dẫn hoặc hỗ trợ nhé. Link facebook ở trên menu đầu trang.
- Các nội dung ở trang này sẽ thường xuyên được biên tập thay đổi và cập nhật. Hãy ghé thăm thường xuyên nhé.
Chúc bạn nhiều thành công.