LẬP TRÌNH MACRO VỚI

VISUALBASIC FOR APPLICATION (VBA)

-------------oOo------------

Để test các Modul ta thực hiện theo các bước sau đây:

1. Nhấn <Alt+F11> để mở cửa sồ VBE (Visual Basic Editor)
2. Vào Insert, chọn Module.
3. Nhập vào đoạn mã vào: (Các hàm trình bày phía dưới)

4. Đóng cửa sổ VBA Editor bằng phím tắt <Alt+Q>, và tại ô A1 nhập vào hàm sau:

=TabName()

5. Nhấn <Enter> và xem kết quả

-------------------------------------------Các hàm tự tạo khá thông dụng---------------------------------------

1. Hàm trả về tên sheet hiện hành

Function TabName()

TabName = ActiveSheet.Name

End Function

2. Hàm trả về tên workbook hiện hành

Function WkbName()

WkbName = ActiveWorkbook.Name

End Function

3. Hàm trả về đường dẫn đến workbook hiện hành

Function WkbPath()

WkbPath = ActiveWorkbook.Path

End Function

4. Hàm trả về tên đầy đủ của workbook

Function WkbFull()

WkbFull = ActiveWorkbook.FullName

End Function

5. Hàm trả về User hiện tại của Windows hoặc Excel

Để lấy tên User Windows hiện hành

Function User()

User = Environ("Username")

End Function

Để lấy tên User Excel hiện hành

Function ExcelUser()
ExcelUser = Application.UserName
End Function

6. Hàm trả về công thức trong một ô (cell) xác định

Function FormT(vdc As Range)

FormT = " " & vdc.Formula

End Function

7. Hàm kiểm tra xem một ô có chứa công thức hay không

Function FormYes(vdc As Range)

FormYes = vdc.HasFormula

End Function

8. Hàm kiểm tra xem một ô (cell) trong bảng tính có đang áp dụng tính năng Data Validation hay không

Function Valid(vdc As Range)

Dim intV As Integer

On Error GoTo errorM

intV = vdc.Validation.Type

Valid = True

Exit Function

errorM:

Valid = False

End Function

9. Hàm kiểm tra xem một ô (cell) có chứa chú thích (comment) hay không

Function ComT(vdc As Range)

On Error GoTo errorM

If Len(vdc.Comment.Text) > 0 Then ComT = True

Exit Function

errorM:

ComT = False

End Function

{--------------Đã XB -------------------}

10. Hàm tính tổng các ô tô nền theo màu xác định

Function SumColor(Area As Range, Ci As Integer)

Dim sng As Single, rng As Range

For Each rng In Area

If rng.Interior.ColorIndex = Ci Then sng =

sng+rng.Value

Next rng

SumColor = sng

End Function

Ghi chú: Màu nền (1=black, 2=white, 3=red, 4=green,5=blue, ...).

11. Hàm tính tổng các ô chứa Font chữ theo màu xác định

Function SumColorF(Area As Range, Ci As Integer)

Dim sng As Single, rng As Range

For Each rng In Area

If rng.Font.ColorIndex = Ci Then sng =

sng+rng.Value

Next rng

SumColorF = sng

End Function

Ghi chú: Màu nền (1=black, 2=white, 3=red, 4=green,5=blue, ...)

12. Hàm xoá bỏ các số 0 đứng trước giá trị số khỏi một ô xác định

Function KillZeros(rng As Range)

Dim intS As Integer

intS = rng

While intS - Int(intS) > 0

intS = intS * 10

Wend

KillZeros = intS

End Function

13. Hàm xoá bỏ các ký tự chữ khỏi một ô xác định

Function LetterOut(rng As Range)

Dim i As Integer

For i = 1 To Len(rng)

Select Case Asc (Mid(rng.Value, i, 1))

Case 0 To 64, 123 To 197

LetterOut = LetterOut & Mid(rng.Value, i, 1)

End Select

Next i

End Function

14. Hàm xoá bỏ tất cả ký tự số khỏi một ô xác định

Function NumberOut(rng As Range)

Dim i As Integer

For i = 1 To Len(rng)

Select Case Asc (Mid(rng.Value, i, 1))

Case 0 To 64, 123 To 197

Case Else

NumberOut = NumberOut & Mid(rng.Value, i, 1)

End Select

Next i

End Function

15. Hàm xác định vị trí của ký tự số đầu tiên trong chuỗi cho trước trong ô

Function FirstNum(rng As Range)

Dim i As Integer

For i = 1 To Len(rng.Value)

Select Case Mid(rng.Value, i, 1)

Case 0 To 9

FirstNum = i

Exit Function

End Select

Next i

End Function

16. Hàm tính tổng tất cả chữ số của con số cho trước trong ô (cell)

Function Qs(rng As Range)

Dim i As Integer

For i = 1 To Len(rng.Value)

Qs = Qs+Cint (Mid(rng.Value, i, 1))

Next i

End Function

17. Hàm tính tổng tất cả chữ số của các con số trong vùng (range)

Function QsE(Area As Range)

Dim i As Integer

Dim rng As Range

For Each rng In Area

For i = 1 To Len(rng.Value)

QsE = QsE+CInt (Mid(rng.Value, i, 1))

Next i

Next rng

End Function

18. Hàm kiểm tra một worksheet có rỗng hay không

Function ShEmpty(s As String) As Boolean

If Application.CountA (Sheets(s).UsedRange) = 0

Then

ShEmpty = True

Else

ShEmpty = False

End If

End Function

19. Hàm kiểm tra một worksheet có đang được bảo vệ (protected) hay không

Function ShProt(s As String) As Boolean

On Error GoTo errorM

If Sheets(s).ProtectContents = True Then

ShProt = True

End If

Exit Function

errorM:

ShProt = False

End Function

20. Hạm tạo AutoText của riêng bạn

Function AuTxt(rng As Range) As String

Select Case rng.Value

Case 1

AuTxt = "fire"

Case 2

AuTxt = "water"

Case 3

AuTxt = "heaven"

Case Else

AuTxt = "invalid text"

End Select

End Function

*Hiện thông báo nhiều dòng: MsgBox Arr(1) & Chr(13) & Arr(2) & vbNewLine & Arr(3) & vbCrLf & Arr(4)

*Hiện thị có cách tab: MsgBox "Ho va ten: " & Ten & vbTab & vbTab & "Tuoi la " & Tuoi

* Hiện thông báo chữ Việt:

B1. Mở file Word mới, bật chức năng Record Macro của MS Word.

B2. Gõ nội dung chữ Việt cần dùng để đưa vào thông báo của VBA.
Vd: Xin chào các bạn Hãy làm quen với VBA nhé!

B3. Vào cửa sổ VBA của Word >> Modunle >> New macro, copy đoạn thông báo chữ Việt rồi vào cửa sổ VBA của Excel sử dụng thông báo sau:
Application.Assistant.DoAlert "Thông báo", "Xin chào các b" & ChrW(7841) & "n" & " Hãy làm quen v" & ChrW(7899) & "i VBA nhé!", 0, 4, 0, 0, 0
Kết quả thu được như hình sau đây:

Chú ý: Mặc định tham số sau cùng trong lệnh Application.... là: 0, 4, 0, 0, 0

* Thay đổi Font:

Sub ChangeFont1()

Selection.Font.Name = “Verdana”

Selection.Font.FontStyle = “Bold Italic”

Selection.Font.Size = 12

Selection.Font.Underline = xlUnderlineStyleSingle

Selection.Font.ColorIndex = 5

End Sub

---------------------------------------------------------------------------------------------------

Sub ChangeFont2()

With Selection.Font

.Name = “Verdana”

.FontStyle = “Bold Italic”

.Size = 12

.Underline = xlUnderlineStyleSingle

.ColorIndex = 5

End With

End Sub

--------------------------------------------------------------------------

expression.InputBox (prompt [, title] [, default], [, left], [, top] [helpfile, context] [, type])

--------------------------------------------------------------------------

4.9.1. Câu lệnh IF
Đây là kiểu đơn giản nhất, mẫu của câu lệnh IF như sau:

If <điều kiện> Then <dòng lệnh 1> [Else <dòng lệnh 2>]

Trong chỉ dẫn trên, các thông số trong [ ] là tuỳ chọn, có thể bỏ qua nếu thấy không cần thiết.
Nếu <điều kiện> được toại nguyện (đúng - True) thì <dòng lệnh 1> được thực hiện, còn nếu không được toại nguyện (sai - False) thì <dòng lệnh 2> được thực hiện.
Thông thường, bạn hay sử dụng câu lệnh If ... then ... Else mà không cần phải giới hạn số dòng lệnh. Mẫu như sau:

If <điều kiện1> Then
<Khối lệnh 1 thực hiện>
[ElseIf <điều kiện2>
<Khối lệnh 2 thực hiện>]
[ElseIf <điều kiện3>
<Khối lệnh 3 thực hiện>]
[Else
<Khối lệnh 4 thực hiện>]
End If

Trong mẫu tổng quát ở trên, từ khoá ElseIf và Else là tuỳ chọn (như biểu thị trong dấu ngoặc vuông). Đầu tiên VB kiểm tra điều kiện thứ nhất, nếu sai thì sẽ chuyển sang điều kiện thứ 2,... cho đến khi điều kiện đúng. VB thi hành khối lệnh tương ứng và sau đó, thi hành dòng chương trình ngay sau End If.
Ví dụ:
Macro dưới đây tìm kiếm giá trị tại ô A1 (là điểm trung bình môn học).

Trích:

Nếu 10 > A1 ≥ 8.0 : “Học lực giỏi”;
Nếu 8 > A1 ≥ 6.5 : “Học lực khá”;
Nếu 6.5 > A1 ≥ 5.0 : “Học lực trung bình”;
Nếu 5 > A1 ≥0 : “Học lực kém”.

Ô B2 thể hiện kết quả học lực.

Sub Hocluc()
Sheets(“Sheet1”).Select
Range(“A1”).Select
If ActiveCell >= 8 Then
Range(“B2”).Value = “Học lực giỏi”
ElseIf ActiveCell >= 6.5 Then
Range(“B2”).Value = “Học lực khá”
ElseIf ActiveCell >= 5 Then
Range(“B2”).Value = “Học lực trung bình”
Else
Range(“B2”).Value = “Học lực kém”
End If
End Sub

Ghi chú: Bạn có thể bỏ qua dòng Range(“A1”).Select thay bằng If Range(“A1”).Value >= 8 Then.
Ngoài ra, bạn cũng có thể sử dụng If để kết thúc macro, câu lệnh như sau có thể sử dụng để kết thúc macro.

If ActiveCell = “” Then End Sub

(nếu ô hiện hành mà trống thì sẽ kết thúc Sub, không cần phải có End If)
Giả sử bạn tìm kiếm giá trị của một ô và bạn muốn kết quả như sau
Dừng macro khi ô đó trống.
• Nhập giá trị “Tốt” vào ngay ô bên phải ô đó nếu có giá trị lớn hơn 40.
• Nhập giá trị “Kém” vào ngay ô bên phải ô đó nếu có giá trị nhỏ hơn 40.

Sub user_If()
If ActiveCell.Value = "" Then Exit Sub
If ActiveCell.Value >= 40 Then
ActiveCell.Offset(0, 1).Value = "Tốt"
Else
ActiveCell.Offset(0, 1).Value = "Xấu"
End If
End Sub

4.9.2. Sử dụng Select Case
Select Case là một dạng của If ... Then ... Else, được sử dụng khi có nhiều điều kiện chọn lọc giá trị. Câu lệnh như sau:

Select Case <biểu thức kiểm tra>
[Case <biểu thức 1>
<khối lệnh 1>]
[Case <biểu thức 2>
<khối lệnh 2>]
[Case <biểu thức 3>
<khối lệnh 3>]
....
[Case Else <biểu thức n>
<khối lệnh n>]
End Select

Mỗi danh sách biểu thức có 1 hay nhiều giá trị. Các giá trị cách nhau bằng dấu phẩy (,). Còn giá trị biến đổi trong vùng thì bạn sử dụng từ khoá To. Mỗi khối lệnh có thể chứa 0 hay nhiều dòng lệnh. Nếu biểu thức nào thoả mãn điều kiện thì khối lệnh tương ứng sẽ thực hiện. Case Else không nhất thiết phải có, dùng trong trường hợp còn lại của các Case trước.

Ô B2 chứa giá trị độ sệt của đất, ô C2 sẽ thể hiện trạng thái của nó.

Sub Trangthai()
Sheets(“Sheet1”).Select
Doset = Cells(2,2).Value
Select Case Doset
Case 1, 1 to 10
Cells(2,3).Value= “Chảy”
Case 0.75 to 1
Cells(2,3).Value= “Dẻo chảy”
Case 0.5 to 0.75
Cells(2,3).Value= “Dẻo mềm”
Case 0.25 to 0.5
Cells(2,3).Value= “Dẻo cứng”
Case 0 to 0.25
Cells(2,3).Value= “Nửa cứng”
Case < 0
Cells(2,3).Value= “Cứng”
End Select
End Sub

4.9.3. Xây dựng các điều kiện
Trong nhiều trường hợp, điều kiện lọc dữ liệu đã trở nên khá phức tạp. Nếu chỉ sử dụng If hay Select Case thì công việc sẽ rất cồng kềnh, rắc rối. Trong hoàn cảnh đó, And và Or giúp bạn thực hiện công việc đó, giúp chương trình sáng sủa và dễ đọc.
4.9.3.1. Sử dụng And
Câu lệnh như sau:

If <điều kiện 1> And <điều kiện 2> Then
<khối lệnh 1>
Else
<khối lệnh 2>
End If

<khối lệnh 1> chỉ thực hiện khi cả hai điều kiện 1 và 2 đều đúng. Chỉ 1 trong 2 điều kiện sai thì <khối lệnh 2> sẽ thực hiện.

4.9.3.2. Sử dụng Or
Câu lệnh như sau:

Trích:

If <điều kiện 1> Or <điều kiện 2> Then
<khối lệnh 1>
Else
<khối lệnh 2>
End If

<khối lệnh 1> thực hiện khi một trong hai điều kiện 1 và 2 đúng. Cả 2 điều kiện sai thì <khối lệnh 2> sẽ thực hiện.
4.9.3.3. Sử dụng nhiều And và Or
Câu lệnh như dưới đây:

Trích:

If <điều kiện 1> And <điều kiện 2> And <điều kiện 3> Then
<khối lệnh 1>
Else
<khối lệnh 2>
End If

<khối lệnh 1> chỉ thực hiện khi cả ba điều kiện đều đúng. Chỉ 1 trong 3 điều kiện sai thì <khối lệnh 2> sẽ thực hiện.
Tương tự đối với Or.

Bạn có thể xác định tên đất dựa vào hệ số rỗng tự nhiên, chỉ số dẻo, độ sệt.

Trích:

Sub Ten_dat()
Dim Hsr, Chisodeo, Doset As Single
Hsr = InputBox("Vao gia tri he so rong:")
Chisodeo = InputBox("Vao gia tri chi so deo:")
Doset = InputBox("Vao gia tri do set:")
If Hsr > 1.5 And Chisodeo >= 17 And Doset > 1 Then
MsgBox "Day la dat BUN SET!"
ElseIf Hsr > 1.0 And Chisodeo >= 7 And Doset > 1 Then
MsgBox "Day la dat BUN SET PHA!"
ElseIf Hsr > 0.9 And Chisodeo >= 1 And Doset > 1 Then
MsgBox "Day la dat BUN CAT PHA!"
Else
MsgBox "Chua ro ten dat!!!!"
End If
End Sub

4.10. Hộp thoại trong VBA

Hộp thoại (Dialog) là một trong những cách thức để Windows giao tiếp với người sử dụng. Dưới đây là 2 loại hộp thoại mà bạn dễ dàng tạo ra để điều khiển trong suốt quá trình chạy macro (MsgBox và InputBox).
4.10.1. Hộp thông báo (Message box)
Câu lệnh MsgBox sẽ cho hiện lên trên màn hình một hộp thông báo, giá trị nhận được là biến số (variable) trong macro (như hình 18). Sử dụng MsgBox giúp bạn rất hiệu quả trong việc gỡ rối (hoặc tìm chỗ sai, giá trị trung gian,...) khi xây dựng chương trình.
Hàm MsgBox ở dạng tổng quát

MsgBox (prompt [, buttons] [, title] [, helpfile, context])

Trên màn hình sẽ hiện hộp thông báo và đợi bạn bấm chuột vào nút chọn và trở về giá trị nguyên nào khi bạn chọn loại nút.

prompt là nội dung lời nhắc của hộp thông báo.
buttons là tuỳ chọn loại nút điều khiển (như Yes, No, OK)
title là tuỳ chọn nội dung chữ trên đầu hộp thông báo
helpfile là tuỳ chọn và điều khiển file trợ giúp nào để sử dụng.
context là tuỳ chọn và là số thứ tự tình huống trong helpfile. Nếu helpfile có thì mục context cũng phải có.

4.10.1.1. Các loại thông điệp trong buttons
4.10.1.2. Mô tả thông số các nút
4.10.1.3. Các biểu tượng thông điệp
Ghi chú: Tại mỗi kiểu thông điệp, âm thanh báo khi hiển thị thông điệp đi kèm theo sẽ khác nhau.
4.10.1.4. Xây dựng tham số cho MsgBox
Để sử dụng tuỳ biến hộp thông báo, bạn phải biết phối hợp các thông số và nút lệnh. Việc sử dụng hộp MsgBox có ý nghĩa rất quan trọng trong việc điều khiển chương trình. Để hiểu chi tiết, các bạn xem ví dụ dưới đây.

Sub Nhangui()
Dim Truonghop As Integer
Truonghop = MsgBox("Ban co muon thoat khoi chuong trinh khong", vbYesNoCancel + vbQuestion + vbDefaultButton1,”Chuong trinh tinh lun”)
If Truonghop = vbYes Then
MsgBox "Ban vua chon nut Yes.", vbInformation
ElseIf Truonghop = vbNo Then
MsgBox "Ban vua chon nut No.", vbCritical
ElseIf Truonghop = vbCancel Then
MsgBox "Ban vua bam nut Cancel.", vbExclamation
End If
End Sub

Hình vẽ dưới thể hiện kết quả chạy Sub trên và hộp thông báo khi bạn chọn nút No. Trong Sub trên, bạn có thể thay

ElseIf Truonghop = vbNo Then
bằng
ElseIf Truonghop = 7 Then

Hình 42: Ví dụ về cách tạo MsgBox trong VB và khi chọn nút No

4.10.2. Phương thức InputBox (Inputbox Method)
Nhằm thể hiện hộp thoại để người sử dụng nhập dữ liệu vào.
Khi sử dụng phương thức này, một hộp thoại sẽ cho hiện ra để bạn vào dữ liệu, chờ cho người dùng nhập dữ liệu vào hoặc là bấm vào nút OK hoặc Cancel, giá trị nhận được được coi là chuỗi (string). Đây là một cách để vào giá trị đơn lẻ hoặc địa chỉ của các ô trong quá trình chạy macro. Bạn không thể gán được lệnh khi chọn nút OK hay Cancel như trong MsgBox. Đó chính là hạn chế của hàm này nên ít được ứng dụng khi đầu vào nhiều số liệu.
Phương thức InputBox ở dạng tổng quát

Trích:

expression.InputBox (prompt [, title] [, default], [, left], [, top] [helpfile, context] [, type])

Expression: một biểu thức trả về đối tượng Application.
prompt là nội dung lời nhắc của hộp vào dữ liệu.
title là tuỳ chọn nội dung chữ trên đầu hộp vào dữ liệu.
left là tuỳ chọn khoảng cách từ góc bên trái hộp thoại đến góc bên trái màn hình (mặc định là hộp thoại nằm giữa màn hình). Đơn vị tính là là điểm (point), một điểm bằng 1/72 inch hay khoảng 1/28 cm. Chức năng này ít sử dụng.
top là tuỳ chọn khoảng cách từ đỉnh hộp thoại đến đỉnh màn hình (mặc định là hộp thoại nằm giữa màn hình). Đơn vị tính là là điểm.
helpfile là tuỳ chọn và điều khiển file trợ giúp nào để sử dụng.
context là tuỳ chọn và là số thứ tự tình huống trong helpfile. Nếu helpfile có thì mục context cũng phải có.
type là tuỳ chọn biến số đầu vào. Trong trường hợp bỏ qua, giá trị đầu vào coi như là chuỗi.

Sub VD_Input()
Dim Dangmang
Dim Cot, Hang As Integer
Set Mang = Application.InputBox("Vao mang:", "Linh tinh", Type:=8)
Cot = Dangmang.Columns.Count ‘ Tính số cột chọn
Hàng = Dangmang.Rows.Count ‘ Tính số hàng chọn
MsgBox "So cot la: " & Cot
MsgBox "So hang la: " & Hang
MsgBox "Dia chi o dau la: " & Dangmang.Cells(1, 1).Address
MsgBox "Dia chi o cuoi la: " & Dangmang.Cells(Cot, Hang).Address ‘ Address Thông Tin địa chỉ ô
End Sub

Kết quả vào dữ liệu là mảng dưới đây. Ngoài ra bạn còn thu được một số thông tin về mảng đó như số hàng, số cột, địa chỉ ô,...
4.11. Hành động lặp (Loop)

Hành động lặp cho phép bạn thực hiện một đoạn chương trình nhiều lần. Chức năng này hết sức có ý nghĩa khi bạn xử lý các đối tượng là mảng. Bạn có thể điều khiển hành động lặp theo quy định đặt ra. Có các kiểu hành động lặp như sau:

4.11.1. Do ... Loop
Thực hiện một khối lệnh với số lần lặp xác định. Trong đó, một biểu thức điều kiện dùng so sánh để quyết định vòng lặp tiếp tục hay không. Điều kiện phải quy về False (0) hoặc True (khác 0). Mẫu tổng quát:

Do
<khối lệnh>
Loop

Sub VD_Do()
m = 4 ‘ m nhận giá trị ban đầu là 4
Do ‘ bắt đầu vòng lặp
m = m + 1 ‘ đặt giá trị m tăng (+ 1)
MsgBox m ‘ hộp thông báo giá trị m
If m > 10 Then Exit Do ‘ nếu m > 10 thì sẽ thoát khỏi Do
Loop ‘ Tiếp tục lặp
End Sub

4.11.2. Do While ... Loop
Thực hiện khối lệnh khi điều kiện True. Hành động sẽ lặp với điều kiện True, cho đến khi điều kiện False thì sẽ thoát ra. Mẫu tổng quát:

Do While <điều kiện>
<khối lệnh>
Loop

Sub VD_DoW_Loop()
i = 1 ‘ Đặt i lúc đầu bằng 1
Do While i <= 10 ‘ Đặt giới hạn cho i, nếu False thì thoát
Cells(i,1) = i ‘ Gán i vào ô
i = i + 1 ‘ Cho giá trị i tăng dần
MsgBox i ‘ Hộp thông báo giá trị i
Loop ‘ Tiếp tục lặp
End Sub

4.11.3. Do ... Loop While
Tương tự như Do While ... Loop, thực hiện khối lệnh khi điều kiện True. Hành động sẽ lặp với điều kiện True, cho đến khi điều kiện False thì sẽ thoát ra. Mẫu tổng quát:

Do
<khối lệnh>
Loop While <điều kiện>

Sub VD_Do_LoopW()
i = 1
Do
Cells(i,3) = i
i = i + 1
Msgbox i
Loop While i <= 10
End Sub

4.11.4. Do Until ... Loop
Bạn có thể thực hiện các khối lệnh từ đầu vòng lặp cho đến khi điều kiện vẫn True. Đến khi điều kiện False thì sẽ thoát ra. Phương thức này giống như vòng lặp For ... Next. Mẫu tổng quát:

Do Until <điều kiện>
<khối lệnh>
Loop

Sub VD_DoU_Loop()
i = 1
Do Until i = 10
Cells(i,5) = i
i = i + 1
MsgBox i
Loop
End Sub ‘Tương tự đối với Do ... Loop Until.

4.11.5. For ... Next
Bạn có thể lặp hành động với số lần biết trước. Ta dùng biến đếm tăng dần hoặc giảm dần trong vòng lặp.

For <biến đếm> = <điểm đầu> To <điểm cuối> [Step <bước nhảy>]
<khối lệnh>
Next [<biến đếm>]

Biến đếm, điểm đầu, điểm cuối, bước nhảy là những giá trị số. Bước nhảy có thể là giá trị dương (tăng) hoặc âm (giảm). Nếu Step không được chỉ định ra, mặc định bước nhảy là 1.

Ví dụ 1: Không dùng Step
Sub VD_ForNext()
For i = 1 To 5
Cells(10, i) = i
MsgBox i
Next
End Sub

Ví dụ 2: Dùng Step
Sub VD_ForNext_Step()
For i = 1 To 7 Step 2
Cells(12, i) = i
MsgBox i
Next
End Sub

4.11.6. For Each ... Next
Tương tự như vòng lặp For ... Next, nhưng nó lặp khối lệnh theo số phần tử của một tập hợp đối tượng hay một mảng, thay vì theo số lần lặp xác định. Vòng lặp này rất tiện lợi khi ta chưa biết chính xác bao nhiêu phần tử trong tập hợp.

For Each <phần tử> In <nhóm>
<khối lệnh>
Next <phần tử>

Để xác định tên và số lượng sheet trong workbook thì bạn dùng thủ tục sau:

Sub ShowWorkSheets()
Dim mySheet As Worksheet
Dim i As Integer : i = 1
For Each mySheet In Worksheets
MsgBox mySheet.Name
i = i + 1
Next mySheet
MsgBox "So sheet trong workbook la " & i
End Sub

4.11.7. Lệnh thoát (Exit)
Trong một số trường hợp, bạn có thể thoát khỏi công việc nào đó khi đã thoả mãn yêu cầu công việc. Bạn có thể sử dụng thủ tục Exit như Exit Do (thoát khỏi vòng lặp Do ... Loop), Exit For (thoát khỏi vòng For ... Next), Exit Function (thoát khỏi hàm), Exit Sub (thoát khỏi chương trình), Exit Property (thoát khỏi thuộc tính đang làm việc).

Sub ExitStatementDemo()
Dim I, MyNum
Do ' Đặt vòng lặp Do Loop
For I = 1 To 1000 ' Lặp 1000 lần
MyNum = Int(Rnd * 1000) ' Tạo số nguyên ngẫu nhiên
Select Case MyNum ' Tính toán với số nguyên trên
Case 7: Exit For ' Nếu là 7, thoát khỏi For...Next
Case 29: Exit Do ' Nếu là 29, thoát khỏi Do...Loop
Case 54: Exit Sub ' Nếu là 54, thoát khỏi vòng Sub
End Select
Next I
Loop
End Sub

4.11.8. Vòng lặp lồng
Vòng lặp có thể được lồng vào nhau. Ứng dụng này rất có hiệu quả khi bạn tính toán với mảng hay đối với bảng tính nhiều chiều.

SubCellsExample()
For i = 1 To 5
For j = 1 To 5
Cells(i, j) = "Row " & i & " Col " & j
Next j
Next i
End Sub

5.1. Sao chép/Dán một vùng dc:

Dim ws As Worksheet

Dim dcn, dcd As String

Sub Rectangle1_Click()

Set ws = Sheets("vidu")

ws.Activate dcn = "A2:D2"

dcd = "A6:D6"

ws.Range(dcn).Copy

ws.Range(dcd).PasteSpecial

End Sub

MỘT SỐ KINH NGHIỆM VBA

Function taofilekq()

name = ActiveSheet.name

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

For Each ws In Worksheets

If ws.name = "Kq_thongke" Then

If MsgBox("Sheet Kq_thongke da co roi! Xoa di de TK lai?", vbYesNo, "Thong bao") = vbYes Then

ws.Delete

End

Else

End

End If

Next ws

Worksheets(ActiveSheet.name).Copy After:=Worksheets(ActiveSheet.name)

ActiveSheet.name = "Kq_thongke"

‘+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Set ws = Sheets(ActiveSheet.name)

vdc = "A1:Z5000"

xoa (vdc)

vdc = "A2:G2"

ws.Range(vdc).Merge

ws.Cells(2, "A") = frmkq.lbtbkq.Caption

ws.Cells(4, "A") = frmkq.td1.Caption

ws.Cells(5, "A") = frmkq.td2.Caption

ws.Cells(6, "A") = frmkq.td3.Caption

ws.Cells(7, "A") = frmkq.td4.Caption

ws.Cells(8, "A") = frmkq.td5.Caption

ws.Cells(4, "B") = frmkq.n1.Caption

ws.Cells(4, "C") = frmkq.n2.Caption

ws.Cells(4, "D") = frmkq.n3.Caption

ws.Cells(4, "E") = frmkq.n4.Caption

ws.Cells(4, "F") = frmkq.n5.Caption

ws.Cells(4, "G") = frmkq.td6.Caption

'=========================================================

vdc = "A4:G8"

taokhung (vdc)

kekhung_vung (vdc)

kekhung_doc (vdc)

vdc = "A2:G8"

doifont_size14 (vdc)

dccot = "A:G"

ws.Range(dccot).ColumnWidth = 15

'=========================================================

Set ws = Sheets(name)

ws.Activate

End Function

Dim ws, ws1, ws2 As Worksheet

Dim wsname, dc1, dc2, dc31, dc32 As String

Dim hmin, hmax, cmin, cmax As Long

Sub khoitao()

Set ws1 = Sheets("vd1")

ws1.Activate

Set ws2 = Sheets("vd2")

ws2.Activate

'wsname = ActiveSheet.Name

For Each ws In Worksheets

If ws.Name = "kq" Then

If MsgBox("Sheet Kq da co roi! Xoa di de ghep lai?", vbYesNo, "Thong bao") = vbYes Then

ws.Delete

End

Else

End

End If

Next ws

Worksheets(ActiveSheet.Name).Copy After:=Worksheets(ActiveSheet.Name)

ActiveSheet.Name = "kq"

End Sub

Sub AutoShape1_Click()

Set ws = Sheets(ActiveSheet.Name)

hmin = 1000

hmax = 1

cmin = 1000

cmax = 1

For Each c In Selection

If hmin > c.Row Then

hmin = c.Row

End If

If hmax < c.Row Then

hmax = c.Row

End If

If cmin > c.Column Then

cmin = c.Column

End If

If cmax < c.Column Then

cmax = c.Column

End If

Next c

'khoitao

MsgBox ("dc:" & Chr(cmin + 64) & hmin & ":" & Chr(cmax + 64) & hmax)

End Sub

---------------Mở file cập nhật dữ liệu--------------------

Option Explicit

Type data

ten As String

ss As Byte

vt As Long

End Type

Dim i, lo, l1, l2, solop As Byte

Dim s10, s11, s12 As Long

Dim c As Range

Dim class10(40) As data

Dim class11(40) As data

Dim class12(40) As data

Dim lop10, lop11, lop12 As String

Dim khoi(40) As data

Sub demsslop10()

For i = 1 To solop

class10(i).vt = 0

For Each c In Selection

If Trim(c.Value) = lop10 & Trim(Str(i)) Then

class10(i).ss = class10(i).ss + 1

class10(i).ten = c.Value

's10 = s10 + 1

End If

Next c

Next i

End Sub

Sub demsslop11()

For i = 1 To solop

class11(i).vt = 0

For Each c In Selection

If Trim(c.Value) = lop11 & Trim(Str(i)) Then

class11(i).ss = class11(i).ss + 1

class11(i).ten = c.Value

's11 = s11 + 1

End If

Next c

Next i

End Sub

Sub demsslop12()

For i = 1 To solop

class12(i).vt = 0

For Each c In Selection

If Trim(c.Value) = lop12 & Trim(Str(i)) Then

class12(i).ss = class12(i).ss + 1

class12(i).ten = c.Value

's12 = s12 + 1

End If

Next c

Next i

End Sub

Sub khoitao()

For i = 1 To solop

class10(i).ss = 0

class10(i).vt = 0

class11(i).ss = 0

class11(i).vt = 0

class12(i).ss = 0

class12(i).vt = 0

Next i

End Sub

Sub CopyCell()

Dim Path, Dir, dcl, name, vlop, vmhs As String

Dim k As Byte

' Thiet lap thu muc

Dir = "D:\Opendata\"

solop = 40

dcl = "B4:B1600"

Range(dcl).Select

lop10 = "10A"

lop11 = "11A"

lop12 = "12A"

s10 = 0

s11 = 0

s12 = 0

khoitao

demsslop10

demsslop11

demsslop12

k = 0

For i = 1 To solop

If class10(i).ten <> "" Then

k = k + 1

khoi(k) = class10(i)

End If

Next i

For i = 1 To solop

If class11(i).ten <> "" Then

k = k + 1

khoi(k) = class11(i)

End If

Next i

For i = 1 To solop

If class12(i).ten <> "" Then

k = k + 1

khoi(k) = class12(i)

End If

Next i

'-----------------------------

khoi(0).vt = 1

For i = 1 To k

khoi(i).vt = khoi(i - 1).vt + khoi(i - 1).ss

Next i

For i = 1 To k

vlop = "C"&khoi(i).vt + 3&":"&"G"&khoi(i).vt + 3 + khoi(i).ss - 1

vmhs = "A"&khoi(i).vt + 3&":"&"A"&khoi(i).vt + 3 + khoi(i).ss - 1

Range(vlop).Select

Selection.Copy

' tao pathname truy xuat file thu i

Path = Dir & "BTH_" & Trim(khoi(i).ten) & ".xls"

Workbooks.Open Filename:=Path ' mo file

Worksheets("Mat_Truoc").Select ' Chon sheet can dan dl

Range("B8").Select 'chon vi tri de dan

' Dan du dl tu clipboard

Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _xlNone, SkipBlanks:=False, Transpose:=False

ActiveWorkbook.Save ' Tu dong luu

ActiveWorkbook.Close ' Dong file

Range(vmhs).Select

Selection.Copy

' tao pathname truy xuat file thu i

Path = Dir & "BTH_" & Trim(khoi(i).ten) & ".xls"

Workbooks.Open Filename:=Path ' mo file

Worksheets("Mat_Truoc").Select ' Chon sheet can dan dl

'chon vi tri de dan

'ActiveSheet.Paste

Range("BF8").Select

Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=_xlNone, SkipBlanks:=False, Transpose:=False

ActiveWorkbook.Save ' Tu dong luu

ActiveWorkbook.Close' Dong file

Next i

End Sub

‘-----------------------------------------------------------------

Sub Macro1()
Workbooks.Add
Windows("lan.xls").Activate
Sheets("Sheet1").Copy Before:=Workbooks("Book1").Sheets(1)
ActiveWorkbook.SaveAs Filename:="D:\Book1.xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub

=======================14/10/2014============================

Dim ws, shn, shd As Worksheet

Dim tmon, tensh As String

Dim maxn, maxd As Byte

Dim dcn, dcd As String

Private Sub cmd_exit_Click()

End

End Sub

Private Sub cmd_ok_Click()

Myfolder = ActiveWorkbook.Path

Dim fs, f, f1, fc, s

Set fs = CreateObject("Scripting.FileSystemObject")

Set f = fs.GetFolder(Myfolder)

Set fc = f.Files

Workbooks.Open Filename:=Myfolder & "\" & frm_dongbo.cmbmon.Value & ".xls"

For Each f1 In fc

If (f1.Name <> "1DongBoSLLDT2014fin.xls") And (f1.Name <> frm_dongbo.cmbmon.Value & ".xls") Then

Workbooks.Open Filename:=Myfolder & "\" & f1.Name

For Each shn In Worksheets

If shn.Cells(2, "D") = frm_dongbo.lbavn.Caption Then

tmon = frm_dongbo.lbavd.Caption & "-" & shn.Cells(2, "C")

Else

If shn.Cells(2, "D") = frm_dongbo.lbly.Caption Then

tmon = frm_dongbo.lbli.Caption & "-" & shn.Cells(2, "C")

Else

If shn.Cells(2, "D") = frm_dongbo.lbtheduc.Caption Then

tmon = "TD" & "-" & shn.Cells(2, "C")

Else

tmon = shn.Cells(2, "D") & "-" & shn.Cells(2, "C")

End If

tensh = shn.Name

Windows(frm_dongbo.cmbmon.Value & ".xls").Activate

'---------------------------------------------

For Each shd In Worksheets

If tmon = shd.Name Then

Worksheets(shd.Name).Select

maxd = Evaluate("=max(A5:A60)")

Windows(f1.Name).Activate

Worksheets(tensh).Select

maxn = Evaluate("=max(A5:A60)")

If maxn = maxd Then

dcn = "E5:P" & Trim(Str(maxn + 4))

Range(dcn).Select

Selection.Copy

Windows(frm_dongbo.cmbmon.Value & ".xls").Activate

Worksheets(tmon).Select

Range("E8").Select

Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _

xlNone, SkipBlanks:=False, Transpose:=False

End If

Next shd

'---------------------------------------------

Windows(f1.Name).Activate

Next shn

ActiveWorkbook.Save

ActiveWorkbook.Close

End If

ActiveWorkbook.Save

End Sub

Option Explicit

Type datamon

monn As String

mond As String

vt As Byte

End Type

Public lop, mon1, mon2 As String

Public hk As String

Public mon(15) As datamon

Public bdf(2) As String

Sub TaoMenu()

Dim cb As CommandBar

Dim cpop As CommandBarPopup

Dim cbtn, cbdn As CommandBarButton

'Lay tham chieu den thanh trinh don

Set cb = Application.CommandBars("Worksheet Menu Bar")

'Tao Menu: "DDN_DongBo_SLLDT" (CommandBarPopup)

Set cpop = cb.Controls.Add(msoControlPopup, , , , True)

cpop.Caption = "DDN_DongBo_SLLDT"

Set cbtn = cpop.Controls.Add(msoControlButton, , , , True)

'Gan thuoc tinh cho MenuItem

cbtn.Caption = "Dong bo" 'Gan tieu de

cbtn.OnAction = "ngoc" 'Gan ma lenh

End Sub

Sub auto_open()

TaoMenu

End Sub

Sub ngoc()

frm_dongbo.Show

End Sub

Dim wb As Workbook

Dim ws As Worksheet

Dim shn, shd As Worksheet

Dim tmon, tensh, fsm, tenhk, luush, ophk As String

Dim maxn, maxd, k, d, l As Byte

Dim ok, bdok As Boolean

Dim dcn, dcd, fn, fd As String

Dim fs, f, f1, f2, fc, s, f11, f22, t1, t2

Function found(st1 As String, st2 As String) As Boolean

Dim i As Byte

For i = 1 To Len(st2)

If Mid(st2, i, Len(st1)) = st1 Then

found = True

Exit For

End If

Next i

End Function

Private Sub cmd_exit_Click()

End

End Sub

Sub luudata()

ActiveWorkbook.Close

End Sub

Sub copdiemthi(t As Byte)

If maxn = maxd Then

Windows(bdf(t)).Activate

Worksheets(luush).Select

dcn = "E5:E" & Trim(Str(maxn + 4))

Range(dcn).Select

Selection.Copy

Windows(fsm).Activate

Range("R8").Select

Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _

xlNone, SkipBlanks:=False, Transpose:=False

ActiveWorkbook.Save

End If

End Sub

Sub copdiemtp(p As Byte)

If maxn = maxd Then

Windows(bdf(p)).Activate

Worksheets(luush).Select

dcn = "E5:P" & Trim(Str(maxn + 4))

Range(dcn).Select

Selection.Copy

Windows(fsm).Activate

Range("E8").Select

Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _

xlNone, SkipBlanks:=False, Transpose:=False

ActiveWorkbook.Save

End If

End Sub

Sub mofile_bd()

Set f1 = fs.GetFolder(fn)

Set f11 = f1.Files

d = 0

bdok = False

For Each t1 In f11

If (Mid(t1.Name, Len(lop) + 1, 1) = "_") And (Mid(t1.Name, 1, Len(lop)) = lop) Then

Workbooks.Open Filename:=fn & "\" & t1.Name

d = d + 1

bdf(d) = t1.Name

maxn = Evaluate("=max(A5:A60)")

bdok = True

End If

End Sub

Function tim(ten As String) As Boolean

Dim tf As String

For i = 1 To 14

If ten = mon(i).monn Then

ten = mon(i).mond

Exit For

End If

Next i ' Tim co mon

Set f2 = fs.GetFolder(fd)

Set f22 = f2.Files

For Each t2 In f22

If found(ten, t2.Name) Then

tim = True

fsm = t2.Name

End If

End Function

Sub mofile_sm(ten As String)

Workbooks.Open Filename:=fd & "\" & ten

ok = True

maxd = Evaluate("=counta(A8:A60)")

End Sub

Sub khoitao()

Myfolder = ActiveWorkbook.Path

Set fs = CreateObject("Scripting.FileSystemObject")

lop = frm_dongbo.cmbmon.Value

If (lop <> "") And (hk <> "") Then

fn = Myfolder & "\" & hk & "\Data_BD"

fd = Myfolder & "\" & hk & "\Data_SM\" & lop

'-----------------------------------------------------

ok = False

Set ws = Sheets("data")

ws.Activate

For i = 1 To 15

mon(i).monn = ws.Cells(i + 1, "D")

mon(i).mond = ws.Cells(i + 1, "E")

Next i

Else

MsgBox "Chon lop va HK "

End

End If

End Sub

Private Sub cmd_ok_Click()

khoitao

mofile_bd ' 2 file diemtp va diemthi

If bdok Then

For l = 1 To d

Windows(bdf(l)).Activate

tenhk = Cells(2, "F")

k = 1

For Each shn In Worksheets

If (shn.Name <> "mau") And tim(shn.Cells(2, "D")) Then

mofile_sm (fsm)

k = k + 1

luush = shn.Name

If (Trim(tenhk) = Trim(ophk)) Then

copdiemthi (l)

Else

copdiemtp (l)

End If

Next l

luudata

Else

MsgBox "Chua co file!"

End If

End Sub

Private Sub opthk1_Change()

hk = "HK1"

ophk = frm_dongbo.opthk1.Caption

End Sub

Private Sub opthk2_Change()

hk = "HK2"

ophk = frm_dongbo.opthk2.Caption

End Sub

---------------------10/10/2015------------------------

Option Explicit

Dim ws As Worksheet

Dim folder, dc, dg As String

Public ci(1), cdj(1), cbh(3) As String

Public tmp, logo, hoten, lop, nk, so, tr As String

Public dcp, dclg, dcwh, dcwhlg, dcthe, dcfull, vung1, vung2 As String

Public h1, h2, hso, htr As Long

Public bcolor, fcolor, htcolor, nkcolor As Long

Sub ngoc1()

thongtin.txtso.SetFocus

thongtin.Show

End Sub

Sub ngoc2()

thuoctinh.Show

End Sub

Sub TaoMenu()

Dim cb As CommandBar

Dim cpop As CommandBarPopup

Dim cmdinthe, cmddoitt As CommandBarButton

'Lay tham chieu den thanh trinh don

Set cb = Application.CommandBars("Worksheet Menu Bar")

'Tao Menu: "Vi du Menu" (CommandBarPopup)

Set cpop = cb.Controls.Add(msoControlPopup, , , , True)

cpop.Caption = thongtin.lbthehs

'Them MenuItem vao Menu1:"Menu Vi du"

Set cmdinthe = cpop.Controls.Add(msoControlButton, , , , True)

Set cmddoitt = cpop.Controls.Add(msoControlButton, , , , True)

'Gan thuoc tinh cho MenuItem

cmdinthe.Caption = thongtin.lbtaothehs 'Gan tieu de

cmdinthe.OnAction = "ngoc1" 'Gan ma lenh

cmddoitt.Caption = thuoctinh.lbthuoctinh 'Gan tieu de

cmddoitt.OnAction = "ngoc2"

End Sub

Sub auto_open()

TaoMenu

End Sub

Function xoakhung_vdc(dc As String)

Range(dc).Select

Selection.Borders(xlInsideVertical).LineStyle = xlNone

Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

Selection.Borders(xlOutline).LineStyle = xlNone

End Function

Function timanh(mhs As String) As String

Dim ff, fsys, fnum, fo

Dim picname As String

Dim i As Long

folder = ActiveWorkbook.Path

Set fsys = CreateObject("Scripting.FileSystemObject")

Set fnum = fsys.GetFolder(folder)

Set ff = fnum.Files

For Each fo In ff

i = i + 1

picname = fo.Name

If (UCase(Right(picname, 3)) = "JPG") And (Mid(picname, 1, Len(picname) - 4) = mhs) Then

timanh = Mid(picname, 1, Len(picname) - 4)

tmp = fo.Name

GoTo kt

End If

kt:

End Function

Sub insertpic(ten As String)

With ActiveSheet.Pictures.Insert(folder & "\" & ten)

.Name = ten

.Left = Range(dcp).Left: .Top = Range(dcp).Top

.Width = Range(dcwh).Width: .Height = Range(dcp).Height

End With

End Sub

Sub insertlogo(lgname As String)

With ActiveSheet.Pictures.Insert(folder & "\" & lgname)

.Name = lgname

.Left = Range(dclg).Left: .Top = Range(dclg).Top + 3

.Width = Range(dcwhlg).Width: .Height = Range(dclg).Height - 5

End With

End Sub

Sub kekhung(dc As String)

Range(dc).Select

'----Tao duong vien tren----

With Selection.Borders(xlEdgeTop)

.LineStyle = xlContinuous

.Weight = xlThick

.ColorIndex = 5

End With

'----Tao duong vien duoi----

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.Weight = xlThick

.ColorIndex = 5

End With

'----Tao duong vien trai---

With Selection.Borders(xlEdgeLeft)

.LineStyle = xlContinuous

.Weight = xlThick

.ColorIndex = 5

End With

'---Tao duong vien phai---

With Selection.Borders(xlEdgeRight)

.LineStyle = xlContinuous

.Weight = xlThick

.ColorIndex = 5

End With

End Sub

Sub thuchien()

Dim i, d, h, dh As Long

Dim t1, t2 As String

Dim ws1 As Worksheet

Dim ws2 As Worksheet

so = thongtin.txtso.Value

tr = thongtin.txttr.Value

Set ws1 = Sheets("danhsach")

ws1.Activate

Set ws2 = Sheets("the")

logo = "logo.jpg"

h = 2

d = 0

dh = 0

Do While ws1.Cells(h, 2) <> ""

d = d + 1

If ws1.Cells(h, 2) = timanh(ws1.Cells(h, 2)) Then

'--------------------------------------------------------------

dcp = ci(d Mod 2) & dh * 10 + 5 & ":" & ci(d Mod 2) & dh * 10 + 8

dcwh = ci(d Mod 2) & ":" & ci(d Mod 2)

'--------------------------------------------------------------

dclg = ci(d Mod 2) & dh * 10 + 2 & ":" & ci(d Mod 2) & dh * 10 + 3

dcwhlg = ci(d Mod 2) & ":" & ci(d Mod 2)

'--------------------------------------------------------------

h1 = dh * 10 + 6

h2 = dh * 10 + 7

hso = dh * 10 + 2

htr = dh * 10 + 3

If d Mod 2 = 0 Then

dh = dh + 1

End If

'-------------------------------------------------------

hoten = ws1.Cells(h, 3) & " " & ws1.Cells(h, 4)

nk = ws1.Cells(h, 7)

'-------------------------------------------------------

ws2.Activate

insertlogo (logo)

insertpic (tmp)

' ------------------------------------------------------

ws2.Cells(h1, cdj(d Mod 2)) = hoten

ws2.Cells(h2, cdj(d Mod 2)) = nk

ws2.Cells(hso, cbh(d Mod 2)) = so

ws2.Cells(htr, cbh(d Mod 2)) = tr

dcthe = cdj(d Mod 2) & hso & ":" & cdj(d Mod 2) & hso + 1

ws2.Range(dcthe).Interior.Color = bcolor

ws2.Range(dcthe).Font.Color = fcolor

ws2.Range(cdj(d Mod 2) & hso + 4).Font.Color = htcolor

ws2.Range(cdj(d Mod 2) & hso + 5).Font.Color = nkcolor

'-------------------------------------------------------

vung1 = cbh(d Mod 2) & hso & ":" & cbh(d Mod 2 + 2) & (hso + 1)

vung2 = cbh(d Mod 2) & (hso + 2) & ":" & cbh(d Mod 2 + 2) & (hso + 7)

kekhung (vung1)

kekhung (vung2)

'-------------------------------------------------------------

ws1.Activate

End If

h = h + 1

Loop

ws2.Activate

End Sub

Tạo file excel mới

Set NewBook = Workbooks.Add

With NewBook

.Title = "MrNgoc"

.Subject = "Ngoc"

.SaveAs Filename:="TenFile.xlsx"

End With

‘-------------------------------------

Tạo Menu khi nháy chuột phải

B1. Chuột phải vào This Workbook à View code và dán đoạn code:

Private Sub Workbook_Open()

Dim MyMenu As Object

Set MyMenu = Application.ShortcutMenus(xlWorksheetCell) _

.MenuItems.AddMenu("This is my Custom Menu", 1)

With MyMenu.MenuItems

.Add "MyMacro1", "MyMacro1", , 1, , ""

.Add "MyMacro2", "MyMacro2", , 2, , ""

End With

Set MyMenu = Nothing

End Sub

B2. Tạo 1 module dán đoạn code:

Public Sub mymacro1()

MsgBox "Macro1 from a right click menu"

End Sub

Public Sub mymacro2()

MsgBox "Macro2 from a right click menu"

End Sub

‘------------------Cập nhật ngày 12/5/2017

Một số kiểu dữ liệu thường dùng trong VBA

1. Kiểu số nguyên (Byte, Integer, Long)

Tên kiểu	Phạm vi	Chiếm trong bộ nhớ
Byte	0 đến 2⁸-1 (0 à 255)	1 Byte
Integer	-2¹⁵ à 2¹⁵-1 (-32.768 à 32.767)	2 Byte (2¹⁵ vì 1 bít chứa dấu)
Long	-2³¹ à 2³¹-1 (-2.147.483.648 à 2.147.483.647)	4 Byte (2³¹ vì 1 bít chứa dấu)

Các phép toán: + - * / Mod (chia lấy phần dư) \ (chia lấy phần nguyên)

VD:

7 mod 3 = 1 8 mod 2 = 0

7 \ 3 = 2 10 / 3 = 3.33..333

2. Kiểu số thực (Single, Double)

- Sử dụng dấu “.” trong biểu diễn thập phân

- Phép toán: + - * /

- Singgle (2Byte); Double (4Byte)

3. Kiểu ngày (Date)

- Hằng viết dưới dạng: #11/4/1983# là ngày 04 tháng 11 năm 1983 (m/d/yyyy).

- Phép toán:

Ngày – Ngày = là khoảng cách giữa hai ngày (theo số ngày)

Ngày – Số = Ngày trước đó (#11/4/1983# - 1 = ngày 3 tháng 11 năm 1983)

Ngày + Số = Ngày sau (#11/4/1983# + 1 = ngày 5 tháng 11 năm 1983).

Ví dụ:

Sub ddmmyyyy()

Dim ngay As Date

ngay = #11/4/1983#

MsgBox ngay & ChrW(10) & ngay + 1 & ChrW(10) & ngay - 1

MsgBox "Ngay: " & Day(ngay) & ChrW(10) & "Thang: " & Month(ngay) & ChrW(10) & "Nam:" & Year(ngay)

End Sub

Tên hàm	Ý nghĩa
date()	Trả về ngày hiện tại
Cdate()	Chuẩn hóa kiểu ngày tháng
Datediff()	Tính khoảng cách thời gian
DateSerial()	Trả về kiểu ngày tháng
IsDate()	Kiểm tra kiểu dữ liệu ngày tháng
Day()	Trả về ngày
Month()	Trả về tháng
Year()	Trả về năm
Weekday()	Trả về thứ trong tuần
Now()	Trả về ngày giờ hiện tại
Hour()	Trả về giờ
Minute()	Trả về phút
Second()	Trả về giây
Time()	Trả về giờ hiện tại
TimeSerial()	Trả về kiểu giờ

3. Kiểu logic (Boolean)

- Chỉ có hai giá trị: True (đúng) và False (sai).

- Hằng: True, False

- Phép toán: AND (và) OR (hoặc) NOT (phủ định)

VD: (a mod 2 =0) And (a mod 3=0) à True thì a là số chẵn và a chia hết cho 3

4. Kiểu xâu kí tự (String)

- Lưu trữ tối đa 256 kí tự.

- Hằng xâu: đặt trong cặp dấu nháy kép Ví dụ: “Ha Noi”

- Phép toán: & (phép ghép xâu)

Ví dụ: “Chu” & “Se” à “ChuSe”;

s1=”Gia” s2=”Lai” à s=s1&“ ”&s2 à S=”Gia Lai”

Một số hàm cho xử lý chuỗi

Tên hàm	Ý nghĩa
LCase	Chuyển chuỗi thành viết thường
UCase	Chuyển chuỗi thành viết hoa
Left	Lấy ký tự bên trái
Right	Lấy ký tự bên phải
Mid	Lấy ký tự ở giữa
Trim	Bỏ dấu cách thừa trong chuỗi
Len	Trả về độ dài của chuỗi

5. Kiểu mảng (Array)

Cách khai báo (mảng một chiều):

Cú pháp: Dim TênMảng(SốPhầnTử) As KiểuPhầnTử

Ví dụ:

Dim a(9) As Integer – mảng 10 phần tử kiểu số nguyên

Dim b(10) As String – mảng 11 phần tử kiểu xâu kí tự

Dim c(4) As Date – mảng 5 phần kiểu ngày

Lưu ý: chỉ số trong mảng một chiều ở trên bắt đầu từ 0

6. Kiểu bản ghi

Cúp pháp:

Type Tên kiểu bản ghi

Trường 1 As Kiểu dữ liệu

Trường 2 As Kiểu dữ liệu

…

Trường n As Kiểu dữ liệu

End Type

Ví dụ:

Type hocsinh

hoten As String

ngaysinh As Date

GT As Boolean

DBT As Double

End Type

Dim teo As hocsinh

à Để tham chiếu đến hoten, giới tính, điểm trung bình của biến teo ta viết:

teo.hoten, teo.GT, teo.DTB…

* Dim dslop(54) As hocsinh ‘Khai báo 1 danh sách tối đa 55 học sinh

à Để tham chiếu đến họ tên của học sinh thứ i ta viết: dslop(i).hoten

7. Khai báo biến [Static|Public|Private|Dim] Tên biến As Kiểu dữ liệu

1. Hàm và thủ tục

1.1. Thủ tục (Sub) – sub-routine

Sub Tên(CácThamSố)

End Sub

Dùng cho các đoạn chương trình lặp đi lặp lại (cần sử dụng nhiều lần).

1.2. Hàm (Function)

Function Tên(CácThamSố) As KiểuDữLiệu

Tên = GiáTrị

End Function

Dùng cho các đoạn tính toán lặp đi lặp lại (cần sử dụng nhiều lần).

Các hàm sử dụng trong các biểu thức, không dùng độc lập. Các sub chỉ dùng độc lập, không dùng trong các biểu thức.

1.3. Phạm vi biến (variable scope)

Biến được khai báo ở đầu module gọi là biến toàn cục (global), có thể sử dụng ở bất kỳ đâu trong module.

Biến khai báo trong sub hoặc function gọi là biến cục bộ (local) và chỉ có thể sử dụng trong phạm vi nó được khai báo.

2. Cấu trúc điều khiển

2.1. If

Dạng 1:

If ĐiềuKiện Then

Các lệnh thực hiện khi ĐiềuKiện = True

End If

VD:

If a < 5 Then

a = a + 1

End If

Dạng 2:

If ĐiềuKiện Then

Các lệnh thực hiện khi ĐiềuKiện = True

Else

Các lệnh thực hiện khi ĐiềuKiện = False

End If

VD:

If ĐTB >= 5 Then

S = “Dau”
Else

S = “Rot”

End If

Dạng 3:

If ĐiềuKiện1 Then

Các lệnh thực hiện khi ĐiềuKiện1 = True

ElseIf ĐiềuKiện2 Then

Các lệnh thực hiện khi ĐiềuKiện2 = True

ElseIf ĐiềuKiện3…

End If

2.2. Select

2.3. For

2.4. For Each

For Each t In BiếnMảng

Các lệnh

VD:

Dim s As Integer, r As Range

s = 0

For Each r In Selection

s = s + r.Value

3. VBA trong Ms Excel

· Workbook: một tập tin Excel trong đó có chứa nhiều worksheet

· ActiveWorkbook là workbook ta đang làm việc

· Workbooks là tất cả các workbook đang mở

· ActiveSheet là sheet ta đang làm việc

· Worksheets là tất cả các sheet trong workbook

· Selection là vùng ô đang chọn trên activesheet (vùng ô chọn có thể là 1 ô hoặc nhiều ô, có thể là nhiều ô không kề nhau).

· Để chỉ ra một sheet cụ thể:

Worksheets(TênSheet) hoặc

Worksheets(ChỉSố) trong đó ChỉSố tính từ 1

VD:

Worksheets(“Sheet1”)

Worksheets(1)

· Lấy một ô trong vùng ô

VD: giả sử vùng chọn là vùng A1:E6

Dim r As Range

Set r = Selection.Cells(2, 3)

r.Value = “O tai vi tri Dong = 2, Cot = 3”

· Lấy một ô trên ActiveSheet

VD: đặt chữ Viet Nam vào ô C5 (dòng 5, cột 3)

Dim r As Range

Set r = Cells(5, 3)

r.Value = “Viet Nam”

· Để chỉ ra một vùng ô cụ thể:

Worksheets(TênSheet).Range(TênVùngÔ) hoặc Worksheets(TênSheet).Range(ĐịaChỉVùngÔ) hoặc

Range(Cells(dòng1, cột1), Cells(dòng2, cột2))

VD:

Worksheet(“Sheet1”).Range(“A2:F6”)

Worksheet(“Sheet1”).Range(“VungTenHang”)

· Range là một kiểu dữ liệu chỉ vùng ô. Khi muốn lưu vùng ô vào biến thì phải khai báo biến kiểu Range.

Phải dùng lệnh Set để gán giá trị vào các biến kiểu Range, Worksheet, Workbook.

VD:

Dim a As Range, b As Range

Set a = Selection

Set b = Range(“A2:A6”)

· Một số thao tác với kiểu Range:

§ Thao tác với Font chữ: tên font (Name), các hiệu ứng (Itatlic = nghiêng, Bold = đậm, Underline = gạch chân), cỡ chữ (Size), màu chữ (Color)

VD:

Dim r As Range

Set r = Selection

r.Font.Name = “Arial” ‘ Tên font

r.Font.Size = 16 ‘ Cỡ chữ

r.Font.Bold = True ‘ Chữ đậm

r.Font.Color = vbRed ‘ Màu chữ

§ Thao tác với viền

LineStyle: xlContinuous, xlDash, xlDot, xlDashDot, xlDouble, xlLineStyleNone

Weight: xlHairline, xlThin, xlMedium, xlThick

VD:

Dim r As Range

For Each r in Selection

With r.Borders

.Color = vbRed

.LineStyle = xlContinuous

.Weight = xlThin

End With

§ Thao tác với nền ô

VD: đạt màu nền là màu vàng

Dim r As Range

Set r = Range(“D3:F7”)

r.Interior.Color = vbYellow

§ Thao tác với giá trị chứa trong ô (value)

VD:

Dim a As Range, b As Range, c as Range

Set a = Range(“A1”)

Set b = Range(“A2”)

Set c = Range(“A3”)

a.Value = “Viet Nam”

b.Value = 123

c.Value = #7/9/2014#

c.Value = c.Value + 2

Biến thường được sử dụng để lưu trữ một giá trị thay đổi. Khi sử dụng biến trong VBA cần nhớ một số quy tắc đặt tên sau:

· Tên biến bắt đầu bằng một chữ cái.

· Trong tên không chứa các kí tự đặc biệt như ., @, &, $, #,! hoặc dấu cách.

· Tên biến không dài quá 255 kí tự.

· Tên biến không được trùng với các từ khóa.

Một số thao tác với Range

Một số thao tác với Books và Sheets

Làm việc với WorkSheet

Biến và kiểu dữ liệu trong VBA

Cấu trúc điều khiển VBA

Để khai báo biến ta sử dụng cú pháp:

Dim <<variable_name>> As <<variable_type>>

varibale_name là tên biến

varibale_type là kiểu của biến

Tuy nhiên Dim chỉ có tác dụng trong mỗi lần chạy. Khi kết thúc Sub hay Function biến sẽ được giải phóng khỏi bộ nhớ. Để biến được sử dụng cho đến khi đóng workbook ta cần khai báo thêm từ khóa static

Một số kiểu dữ liệu trong VBA bạn có thể sử dụng:

Kiểu	Nhận giá trị
Byte	0 đến 255
Integer	-32,768 đến 32,767
Long	-2,147,483,648 đến 2,147,483,648
Single	-3.402823E+38 đến -1.401298E-45
Double	-1.79769313486232e+308 đến -4.94065645841247E-324
Currency	-922,337,203,685,477.5808 đến 922,337,203,685,477.5807
Decimal	+/- 79,228,162,514,264,337,593,543,950,335
String	65,400 ký tự
Date	Ngày tháng từ năm 100 đến năm 9999
Boolean	True hoặc False

Mặc định khi không báo kiểu dữ liệu VBA sẽ tự gán cho giá trị kiểu Integer nhưng trong một số trường hợp bạn sẽ bị thông báo lỗi. Ví dụ như khi ta thực hiện phép toán a = 100*500 kết quả là 50000 nhưng kiểu Integer chỉ có thể chứa giá trị max là 32767. Để khắc phục lỗi này ta sẽ phải chuyển đổi kiểu dữ liệu cho các số hạng trong phép toán. Một số kiểu chuyển đổi hay gặp là:

Cú pháp	Ý nghĩa
CBool	Chuyển sang kiểu Boolean
CByte	Chuyển sang Kiểu Byte
CCur	Chuyển sang kiểu tiền tệ
CDate	Chuyển sang kiểu ngày tháng
CDbl	Chuyển sang kiểu Double
Clng	Chuyển sang kiểu Long

Dữ liệu kiểu chuỗi: Để khai báo dữ liệu kiểu chuỗi ta thường đặt giá trị trong dấu ”

a = "Học VBA" ' khai báo chuỗi bình thường

b = "Hôm nay là thứ 7" ' khai báo chuỗi gồm các ký tự và chữ số

c = "@#$#!#" 'khai báo biến gồm các ký tự đặc biệt

d = "plc1810@gmail.com" 'khai báo chuỗi có các ký tự hỗn hợp chữ, số và ký tự đặc biệt

Một số ví dụ:

a = "Ha noi"

a1 = "124 Dich Vong Hau"

c = " 12 Pho Hue "

Range("B2") = Len(a & a1)

Range("B3") = Right(a1, 3)

'lay chu Ha

Range("B2") = Left(a, 2)

'lay chu hau trong chuoi a1

Range("B3") = Right(a1, 3)

'lay chu Dich Vong

Range("B4") = Mid(a1, 5, 9)

'Viet hoa chu HA NOI

Range("B5") = UCase(a)

'Viet thuong chu ha noi

Range("B6") = LCase(a)

'Bo dau cach thua trong chuoi c do ham trim trong VBA bi loi nen su dung o trung gian

Range("B7") = c

Range("B8") = "=Trim(B7)"

Dim ok As Boolean

Public Sub auto_open()

ok = False

For Each mysheet In Worksheets

If mysheet.Name = "Serial" Then

ok = True

End

End If

If ok Then

MsgBox "OK"

Else

Sheets.Add

ActiveSheet.Name = "Serial"

End If

End Sub

Sub taoFlie()

Dim wb As Workbook

Set wb = Workbooks.Add

End sub

Save a Workbook to a Specific Folder

The following example show you how to save an Excel Workbook in Specific folder using SaveAs method:

Sub ExampleToSaveWorkbook()

Workbooks.Add

'Saving the Workbook

ActiveWorkbook.SaveAs "C:\WorkbookName.xls"

'OR

'ActiveWorkbook.SaveAs Filename:="C:\WorkbookName1.xls"

End Sub

Set to an Object and Save it

Set to an Object and Save it, so that it is easy to refer to your workbook to do further tasks. If you are dealing with more than one workbook, you will need this method to access a specific Excel Workbook.

Tạo 5 workbooks đặt tên và lưu

Sub Bevel1_Click()

Dim i As Byte

Dim wkb As Workbook 'Adding New Workbook

For i = 1 To 5

 Set wkb = Workbooks.Add 'Saving the Workbook

 'wkb.SaveAs "D:\WorkbookName.xls" 'OR

 wkb.SaveAs Filename:="D:\" & Str(i) & "_Try_Ngoc.xls"

 wkb.Close 'Close Workbook

Next i

End Sub

Hiển thị các Sheet bị Hide

Sub Rectangle1_Click()

For Each Sheet In Worksheets

Sheet.Visible = -1

End Sub

With Sheet1 ‘ Với Sheet1

.[A1].CurrentRegion.ClearContents ‘Xóa dữ liệu ô A1

.[A5] = "Dao Dinh Ngoc" ‘ Đặt giá trị vào ô A5

End With

Sub DemSoKyTu()

Dim S As String, i As Long, k As Long, Arr()

S = InputBox("Nhap chuoi:") 'Hien hop thoai nhap chuoi tu ban phim

If S = "" Then Exit Sub 'Neu khong nhap chuoi thi thoat khoi Sub

ReDim Arr(1 To Len(S), 1 To 2) 'Khoi tao mang Arr de luu ket qua thong ke

With CreateObject("Scripting.Dictionary") 'Lam viec voi Dictionary

For i = 1 To Len(S) 'Duyet tu dau den cuoi chuoi S

If Not .Exists(Mid(S, i, 1)) Then 'Neu ky tu thu i chua co trong Dictionary

k = k + 1 'Tang bien dem len 1 don vi

.Add Mid(S, i, 1), k 'Them ky tu vao Dictionary voi Item = k

Arr(k, 1) = Mid(S, i, 1) 'Gan ky tu thu i vao phan tu thu k cua mang

Arr(k, 2) = 1 'Dem 1 ky tu

Else 'Nguoc lai (ky tu thu i da ton tai trong Dictionary

Arr(.Item(Mid(S, i, 1)), 2) = Arr(.Item(Mid(S, i, 1)), 2) + 1 'Tang gia tri dem cho ky tu thu i

End If

With Sheet1 'Lam viec voi Sheet1

.[A1].CurrentRegion.ClearContents 'Xoa du lieu hien co

.[A1] = S 'Chuoi vua nhap vao

.[A2].Resize(k, 2) = Arr 'Gan mang len sheet

End With

End Sub

Application.ScreenUpdating = False/False: Tắt/Bật chế độ cập nhật màn hình

Application.Calculation = xlCalculationManual để tắt chế độ tính toán tự động Application.Calculation=xlCalculationAutomatic. để bật chế độ tính toán tự động

Hàm Ubound, Lbound: trả về phần tử cuối cùng, đầu tiên của mảng

Rows("9:9").Select ‘Chọn hàng 9

Selection.AutoFilter ‘ vùng chọn.tự động đặt lọc

ActiveSheet.Range("$A$9:$AS$50").AutoFilter Field:=6, Criteria1:="5.4"

Field:=x {Cột cần lọc là số x}, Criterial:=”5.4” {điều kiện lọc}

THỰC HIỆN HÀM CỦA EXCEL TRONG VBA

cto = "=Match(" & """" & tcm & """" & ",D:D,0)" 'Tao cong thuc dang =Match("Sinh-KTNN",D:D,0)

vto = Evaluate(cto) 'Thuc hien cong thuc tim vi tri to

cttv = "=Countif(D:D," & """" & tcm & """" & ")" 'Tao cong thuc dang =Coutif(cot,dkien)

tov = Evaluate(cttv) ' Thuc hien cong thuc dem so luong to vien

folder = ActiveWorkbook.Path 'Xac dinh duong dan luu file

Thursday, December 28, 2017

VBA #ReadMore

Một số kiểu dữ liệu thường dùng trong VBA

1. Kiểu số nguyên (Byte, Integer, Long)

Tên kiểu

Phạm vi

Chiếm trong bộ nhớ

Byte

0 đến 28-1 (0 à 255)

1 Byte

Integer

-215 à 215-1

2 Byte

Long

-231 à 231-1

4 Byte

2. Kiểu số thực (Single, Double)

3. Kiểu ngày (Date)

3. Kiểu logic (Boolean)

4. Kiểu xâu kí tự (String)

Ví dụ: “Chu” & “Se” à “ChuSe”;

s1=”Gia” s2=”Lai” à s=s1&“ ”&s2 à S=”Gia Lai”

5. Kiểu mảng (Array)

1. Hàm và thủ tục

1.1. Thủ tục (Sub) – sub-routine

1.2. Hàm (Function)

1.3. Phạm vi biến (variable scope)

2. Cấu trúc điều khiển

2.1. If

2.2. Select

2.3. For

2.4. For Each

3. VBA trong Ms Excel

Save a Workbook to a Specific Folder

Set to an Object and Save it

Hiển thị các Sheet bị Hide

End With

With Sheet1 'Lam viec voi Sheet1

.[A1].CurrentRegion.ClearContents 'Xoa du lieu hien co

.[A1] = S 'Chuoi vua nhap vao

.[A2].Resize(k, 2) = Arr 'Gan mang len sheet

End With

End Sub

0 đến 2⁸-1 (0 à 255)

-2¹⁵ à 2¹⁵-1

-2³¹ à 2³¹-1