Ví dụ về lệnh macro

Để thực hiện các mã ví dụ về lệnh macro, đầu tiên thêm một module vào sổ làm việc Excel của bạn, hoặc nếu bạn có một sổ làm việc Macro cá nhân, bạn có thể sử dụng một module hiện có ở đó, hoặc thêm mới. Để làm điều này, bạn cần nằm trong Visual Basic Editor (VBE). Để vào VBE, nhấn ALT + F11 hoặc nhấp vào Visual Basic Option trong tab Developer của bạn.

1. Đánh số thứ tự tự động
Code macro sau đây sẽ giúp bạn bổ sung đánh số thứ tự tự động trên trang Excel.
Sau khi bạn chạy mã macro này, màn hình sẽ hiển thị input box để bạn nhập tối đa số serial và sau đó, nó sẽ chèn các số vào cột theo thứ tự.

Sub AddSerialNumbers()
Dim i As Integer
On Error GoTo Last
i = InputBox("Enter Value", "Enter Serial Numbers")
For i = 1 To i
ActiveCell.Value = i
ActiveCell.Offset(1, 0).Activate
Next i
Last:Exit Sub
End Sub

2. Xóa tất cả các hàng trống
Macro ví dụ này sẽ xóa tất cả các hàng trống trong trang tính.

Sub DeleteBlankRows()
Dim x As Long

With ActiveSheet
For x = .Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
If WorksheetFunction.CountA(.Rows(x)) = 0 Then
ActiveSheet.Rows(x).Delete
End If
Next
End With

End Sub

3. Chèn nhiều cột
Sau khi chạy mã macro dưới đây, màn hình sẽ hiển thị một input box và bạn phải nhập số cột mà bạn muốn chèn.

Sub InsertMultipleColumns()
Dim i As Integer
Dim j As Integer
ActiveCell.EntireColumn.Select
On Error GoTo Last
i = InputBox("Enter number of columns to insert", "Insert Columns")
For j = 1 To i
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromRightorAbove
Next j
Last: Exit Sub
End Sub

4. Chèn nhiều hàng
Khi chạy mã macro sau, màn hình sẽ hiển thị một input box và bạn phải nhập số hàng mà bạn muốn chèn.

Sub InsertMultipleRows()
Dim i As Integer
Dim j As Integer
ActiveCell.EntireRow.Select
On Error GoTo Last
i = InputBox("Enter number of columns to insert", "Insert Columns")
For j = 1 To i
Selection.Insert Shift:=xlToDown, CopyOrigin:=xlFormatFromRightorAbove
Next j
Last: Exit Sub
End Sub

5. Tự động căn chỉnh cột

Sub AutoFitColumns()
Cells.Select
Cells.EntireColumn.AutoFit
End Sub

6. Tự động căn chỉnh hàng

Sub AutoFitRows()
Cells.Select
Cells.EntireRow.AutoFit
End Sub

7. Hiển thị tất cả các dòng và cột đã bị ẩn
Thay vì hiển thị từng hàng và cột một cách thủ công, bạn có thể sử dụng mã này để thực hiện chỉ trong một bước.

Sub UnhideRowsColumns()
Columns.EntireColumn.Hidden = False
Rows.EntireRow.Hidden = False
End Sub

8. Xóa Wrap Text
Mã code này sẽ giúp bạn xóa WrapText khỏi toàn bộ worksheet với một cái nhấp chuột. Đầu tiên nó sẽ chọn tất cả các cột và sau đó xóa WrapText và tự động căn chỉnh độ rộng các hàng và cột.

Sub RemoveWrapText() 
Cells.Select 
Selection.WrapText = False 
Cells.EntireRow.AutoFit 
Cells.EntireColumn.AutoFit 
End Sub

9. Bỏ hợp nhất các ô
Chọn các ô và chạy mã này, nó sẽ không trộn tất cả các ô (Merge Cells) vừa chọn với dữ liệu bị mất của bạn.

Sub UnmergeCells()
Selection.UnMerge
End Sub

10. Mở Calculator
Trong cửa sổ của một bảng tính cụ thể, và hãy sử dụng mã macro này, bạn có thể mở máy tính trực tiếp từ Excel cho việc tính toán.

Sub OpenCalculator()
Application.ActivateMicrosoftApp Index:=0
End Sub

11. Nhân tất cả các số với một số cụ thể
Ví dụ: bạn có một danh sách các số và bạn muốn nhân tất cả các số với một số cụ thể. Chọn một phạm vi các ô và chạy mã này. Đầu tiên mã sẽ yêu cầu bạn nhập số mà bạn muốn nhân và sau đó ngay lập tức sẽ nhân tất cả các số trong ô với số đó.

Sub multiplyWithNumber()
Dim rng As range
Dim c As Integer
c = InputBox("Enter number to multiple", "Input Required")
For Each rng In Selection
If WorksheetFunction.IsNumber(rng) Then
rng.Value = rng * c
Else
End If
Next rng
End Sub

Tương tự, bạn cũng có thể thêm một số vào một bộ số.

Sub addNumber()
Dim rng As range
Dim i As Integer
i = InputBox("Enter number to multiple", "Input Required")
For Each rng In Selection
If WorksheetFunction.IsNumber(rng) Then
rng.Value = rng + i
Else
End If
Next rng
End Sub

12. Thay thế các ô rỗng bằng giá trị 0
Đối với dữ liệu có ô khoảng trắng, bạn có thể sử dụng mã dưới đây để thêm số vào những ô trắng này. Bạn sẽ sử dụng những ô này cho các tính toán sau một cách dễ dàng với mã này.

Sub replaceBlankWithZero()
Dim rng As range
Selection.Value = Selection.Value
For Each rng In Selection
If rng = "" Or rng = " " Then
rng.Value = "0"
Else
End If
Next rng
End Sub

13. Tính căn bậc hai, bậc ba của các số trong vùng được chọn
Bạn có thể sử dụng mã này để tính số căn bình phương mà không cần áp dụng công thức. Mã sẽ kiểm tra tất cả các ô được chọn và chuyển đổi các số thành căn bình phương của chúng.

Sub getSquareRoot()
Dim rng As range
Dim i As Integer
For Each rng In Selection
If WorksheetFunction.IsNumber(rng) Then
rng.Value = Sqr(rng)
Else
End If
Next rng
End Sub

Mã sau sẽ kiểm tra tất cả các ô được chọn và chuyển đổi các số thành căn bậc ba của chúng.

Sub getCubeRoot()
Dim rng As range
Dim i As Integer
For Each rng In Selection
If WorksheetFunction.IsNumber(rng) Then
rng.Value = rng ^ (1 / 3)
Else
End If
Next rng
End Sub

14. Thêm thông tin ở chân trang/đầu trang
Sử dụng mã này để bổ sung ngày vào phần Header và Footer trong worksheet.
Bạn có thể điều chỉnh mã này để đổi từ Header sang Footer.

Sub DateInHeader()
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "&D"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
End With
ActiveWindow.View = xlNormalView
End Sub

Nếu bạn muốn chèn Header tùy chỉnh thì đây là một mã dành cho bạn.
Chạy mã này, nhập giá trị tùy chỉnh vào input box. Để thay đổi liên kết của Header hoặc Footer, bạn có thể điều chỉnh mã.

Sub CustomHeader()
Dim myText As String
myText = InputBox("Enter your text here", "Enter Text")
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = myText
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
End With
End Sub

15. In vùng được chọn

Sub printSelection()
Selection.PrintOutCopies:=1, Collate:=True
End Sub

16. Chuyển đổi tất cả các công thức sang giá trị
Đơn giản chỉ là chuyển đổi các formulas trong vùng chọn sang values.
Khi bạn chạy mã macro này, mã sẽ thay đổi các formulas sang các absolute values.

Sub ConvertToValues()
Dim MyRange As range
Dim MyCell As range
Select Case MsgBox("You Can't Undo This Action. " & "Save Workbook First?", vbYesNoCancel, "Alert")
Case Is = vbYes
ThisWorkbook.Save
Case Is = vbCancel
Exit Sub
End Select
Set MyRange = Selection
For Each MyCell In MyRange
If MyCell.HasFormula Then
MyCell.Formula = MyCell.Value
End If
Next MyCell
End Sub

17. Xóa tất cả các khoảng trắng (space) trong bảng tính
Đây là một trong những mã macro hữu ích nhât trong danh sách này. Mã sẽ kiểm tra selection của bạn và sau đó xóa tất cả khoảng trắng từ selection đó.

Sub RemoveSpaces()
Dim myRange As range
Dim myCell As range
Set myRange = Selection
For Each myCell In myRange
If Not IsEmpty(myCell) Then
myCell.Replace What:=" ", Replacement:="", LookAt:=xlPart
End If
Next myCell
End Sub

Và, thay thế tất cả khoảng trắng trong toàn bảng tính:

Sub ReplaceSpaces()
Application.ScreenUpdating = False
Dim c As range
    For Each c In ActiveSheet.UsedRange
    c = Replace(c.Value, " ", "")
    Next
Application.ScreenUpdating = True
End Sub

18. Xóa hàng loạt ký tự trong bảng tính
Bạn có thể sử dụng mã này để xóa một ký tự cụ thể từ ô được chọn. Mã sẽ hiển thị một input box để nhập ký tự mà bạn muốn xóa.

Sub removeChar()
Dim Rng As Range
Dim rc As String
rc = InputBox("Character(s) to Replace", "Enter Value")
For Each Rng In Selection
Selection.Replace What:=rc, Replacement:=""
Next
End Sub

19. Chèn thêm ký tự Degree Symbol
Ví dụ: bạn có một danh sách các số trong một cột và bạn muốn thêm degree symbol (độ C, độ F,…) vào chúng thì dùng đoạn mã sau.

Sub degreeSymbol()
Dim rng As range
For Each rng In Selection
rng.Select
If ActiveCell <> "" Then
If IsNumeric(ActiveCell.Value) Then
ActiveCell.Value = ActiveCell.Value & Chr(176)
End If
End If
Next
End Sub

20. Đảo ngược tất cả các ký tự trong ô
Bạn chỉ cần nhập công thức =rvrse(cell) vào một ô và chuyển đến ô có văn bản mà bạn muốn đảo ngược. Đoạn mã Function đó như sau:

Public Function rvrse(ByVal cell As Range) As String
rvrse = VBA.strReverse(cell.Value)
End Function

21. Đếm tất cả các từ có trong worksheet
Mã có thể giúp bạn đếm tất cả các từ trong một worksheet.

Sub Word_Count_Worksheet()
Dim WordCnt As Long
Dim rng As range
Dim S As String
Dim N As Long
For Each rng In ActiveSheet.UsedRange.Cells
S = Application.WorksheetFunction.Trim(rng.Text)
N = 0
If S <> vbNullString Then
N = Len(S) - Len(Replace(S, " ", "")) + 1
End If
WordCnt = WordCnt + N
Next rng
MsgBox "There are total " & Format(WordCnt, "#,##0") & " words in the active worksheet"
End Sub

22. Kích hoạt R1C1 reference style, hiển thị DataForm nhập tự động
Mã macro này sẽ giúp bạn kích hoạt R1C1 reference style mà không phải sử dụng Excel options.

Sub DataForm()
ActiveSheet.ShowDataForm
End Sub

23. Chuyển đổi chữ hoa, chữ thường
Chọn các ô và chạy mã này. Mã sẽ kiểm tra mỗi một ô của phạm vi được chọn và sau đó chuyển đổi chúng sang văn bản chữ hoa.

Sub convertUpperCase()
Dim Rng As Range
For Each Rng In Selection
If Application.WorksheetFunction.IsText(Rng) Then
Rng.Value = UCase(Rng)
End If
Next
End Sub

Mã này sẽ giúp bạn chuyển đổi văn bản được chọn sang văn bản chữ thường. Chỉ cần chọn một phạm vi các ô có văn bản và chạy mã này. Nếu một ô có 1 số hoặc bất kỳ giá trị nào không phải là văn bản thì giá trị đó sẽ được giữ lại.

Sub convertLowerCase()
Dim Rng As Range
For Each Rng In Selection
If Application.WorksheetFunction.IsText(Rng) Then
Rng.Value= LCase(Rng)
End If
Next
End Sub

Mã này sẽ chuyền đổi văn bản được chọn sang tên riêng mà có chữ cái đầu từ được viết hoa và phần còn lại được viết thường.

Sub convertProperCase()
Dim Rng As Range
For Each Rng In Selection
If WorksheetFunction.IsText(Rng) Then
Rng.Value= WorksheetFunction.Proper(Rng.Value)
End If
Next
End Sub

Trong trường hợp văn bản, từ đầu tiên có chữ cái đầu câu viết hoa và phần còn lại viết thường trong mỗi câu thì mã này sẽ giúp bạn chuyển đổi văn bản thường thành câu có chữ cái đầu được viết hoa.

Sub convertTextCase()
Dim Rng As Range
For Each Rng In Selection
If WorksheetFunction.IsText(Rng) Then
Rng.Value= UCase(Left(Rng, 1)) & LCase(Right(Rng, Len(Rng) -1))
End If
Next rng
End Sub

24. Thêm tự động bộ chữ cái (hoa, thường) vào bảng tính
Cũng giống như các dãy số, bạn cũng có thể chèn các chữ cái vào worksheet.
Đoạn mã sau sẽ giúp bạn làm điều đó.

'Chữ hoa
Sub addcAlphabets()
Dim i As Integer
For i = 65 To 90
ActiveCell.Value = Chr(i)
ActiveCell.Offset(1, 0).Select
Next i
End Sub

'Chữ thường
Sub addsAlphabets()
Dim i As Integer
For i = 97 To 122
ActiveCell.Value = Chr(i)
ActiveCell.Offset(1, 0).Select
Next i
End Sub

25. Chuyển đổi các ký hiệu số La Mã sang dạng số
Đôi khi, rất khó để nhận biết số La Mã là số seri. Mã này sẽ giúp bạn chuyển đổi số La Mã sang số Arabic.

Sub convertToNumbers()
Dim rng As range
Selection.Value = Selection.Value
For Each rng In Selection
If Not WorksheetFunction.IsNonText(rng) Then
rng.Value = WorksheetFunction.Arabic(rng)
End If
Next rng
End Sub

26. Highlight các bản sao (cùng giá trị) từ vùng được chọn
Mã macro sau đây sẽ kiểm tra mỗi ô bạn chọn và làm nổi bật các giá trị trùng lặp (cùng giá trị).
Bạn cũng có thể thay đổi màu sắc ColorIndex từ mã này.

Sub HighlightDuplicateValues()
Dim myRange As Range
Dim myCell As Range
Set myRange = Selection
For Each myCell In myRange
If WorksheetFunction.CountIf(myRange, myCell.Value) > 1 Then
myCell.Interior.ColorIndex = 36
End If
Next myCell
End Sub

27. Tô màu dòng và cột ô đang được chọn
Đoạn mã sau sẽ làm nổi bật dòng và cột đang được chọn bằng cách DoubleClick vào ô.
Hãy lưu ý rằng, khi áp dụng mã macro này bạn sẽ không thể điều chỉnh ô bằng cách nhấp đúp chuột.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim strRange As String
strRange = Target.Cells.Address & "," & _
Target.Cells.EntireColumn.Address & "," & _
Target.Cells.EntireRow.Address
Range(strRange).Select
End Sub

28. Highlight làm nổi bật các ô trống
Macro cơ bản này sẽ làm nổi bật các ô trống trong vùng chọn

' Highlight all Blank Cells in Selection
Sub HighlightBlankCells()
Dim rng As Range
Set rng = Selection
rng.SpecialCells(xlCellTypeBlanks).Interior.Color = vbCyan
End Sub

29. Highlight làm nổi bật các dòng xen kẽ
Macro này hữu ích để làm nổi bật các hàng xen kẽ.

' Highlight Alternate Rows
Sub highlightAlternateRows()
Dim cell As Range
Dim myRange As Range

Set myRange = Selection

For Each cell In myRange.Rows
If cell.Row Mod 2 = 1 Then
cell.Interior.ColorIndex = 39
End If
Next cell
End Sub

30. Highlight top 10 giá trị
Chỉ cần bạn chọn một phạm vi chứa các giá trị cần tô màu và chạy mã macro sau đây. Đoạn mã thực thi sẽ làm nổi bật 10 giá trị lớn nhất với màu xanh.

Sub TopTen()
Selection.FormatConditions.AddTop10
Selection.FormatConditions(Selection.FormatConditions.Count).S
tFirstPriority
With Selection.FormatConditions(1)
.TopBottom = xlTop10Top
.Rank = 10
.Percent = False
End With
With Selection.FormatConditions(1).Font
.Color = -16752384
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13561798
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
End Sub

31. Tô màu vùng đã được đặt tên (Highlight Named Ranges)
Nếu bạn không chắc chắn bao nhiêu vùng được đặt tên trong worksheet của bạn thì bạn có thể sử dụng mã này để làm nổi bật chúng.

Sub HighlightRanges()
Dim RangeName As Name
Dim HighlightRange As Range
On Error Resume Next
For Each RangeName In ActiveWorkbook.Names
Set HighlightRange = RangeName.RefersToRange
HighlightRange.Interior.ColorIndex = 33
Next RangeName
End Sub

32. Highlight Greater than Values
Sau khi chạy mã này, nó sẽ yêu cầu giá trị mà bạn muốn làm nổi bật các giá trị lớn hơn.

Sub HighlightGreaterThanValues()
Dim i As Integer
i = InputBox("Enter Greater Than Value", "Enter Value")
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:=i
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1)
.Font.Color = RGB(0, 0, 0)
.Interior.Color = RGB(31, 218, 154)
End With
End Sub

33. Highlight Lower than Values
Khi muốn làm nổi bật các giá trị nhỏ hơn, chạy mã sau:

Sub HighlightLowerThanValues()
Dim i As Integer
i = InputBox("Enter Lower Than Value", "Enter Value")
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, Formula1:=i
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1)
.Font.Color = RGB(0, 0, 0)
.Interior.Color = RGB(217, 83, 79)
End With
End Sub

34. Highlight các số âm
Chọn một phạm vi các ô và chạy mã này. Nó sẽ kiểm tra mỗi ô trong phạm vi này và làm nổi bật tất cả các ô có giá trị âm (negative numbers).

Sub HighlightNegativeNumbers()
Dim Rng As Range
For Each Rng In Selection
If WorksheetFunction.IsNumber(Rng) Then
If Rng.Value < 0 Then
Rng.Font.Color = -16776961
End If
End If
Next
End Sub

35. Highlight ký tự văn bản cụ thể cần tìm
Giả sử bạn có một tệp dữ liệu lớn và bạn muốn kiểm tra một chuỗi ký tự hoặc giá trị cụ thể. Trong trường hợp này, bạn có thể sử dụng mã này. Khi bạn chạy nó, màn hình sẽ hiện input box để bạn nhập giá trị muốn tìm kiếm.

Sub HighlightValue()
Application.ScreenUpdating = False
Dim Str As String, FindCll As Range, FindCLlAdd As String, i As Long
Str = InputBox("Enter Text Search", "Search")
Set FindCll = Cells.Find(What:=Str, After:=[IV65536], LookAt:=xlPart)
If FindCll Is Nothing Then Exit Sub
FindCLlAdd = FindCll.Address
Do
i = 1
Do Until InStr(i, FindCll.Value, Str) = 0
i = InStr(i, FindCll.Value, Str)
With FindCll.Characters(Start:=i, Length:=Len(Str)).Font
.FontStyle = "Bold"
.Color = -16776961
End With
i = i + Len(Str)
Loop
Set FindCll = Cells.FindNext(After:=FindCll)
Loop Until FindCll.Address = FindCLlAdd
Application.ScreenUpdating = True
End Sub

36. Highlight các ô có nhận xét
Để làm nổi bật tất cả các ô sử dụng Comments hãy dùng macro sau đây. Các ô chứa Comments sẽ được định dạng làm nổi bật lên.

Sub HighlightCommentCells()
Selection.SpecialCells(xlCellTypeComments).Select
Selection.Style = "Note"
End Sub

37. Tô màu những ô có giá trị duy nhất (không trùng)
Đoạn mã này sẽ làm nổi bật tất cả các ô được chọn mà có giá trị duy nhất.

Sub HighlightUniqueValues()
Dim rng As Range
Set rng = Selection
rng.FormatConditions.Delete
Dim uv As UniqueValues
Set uv = rng.FormatConditions.AddUniqueValues
uv.DupeUnique = xlUnique
uv.Interior.Color = vbGreen
End Sub

38. Tô màu những ô có giá trị bị trùng lặp
Sử dụng macro này để làm nổi bật tất cả các giá trị trùng lặp trong một vùng chọn.

' Highlight Duplicate Values in Selection
Sub HighlightDuplicateValues()
Dim myRange As Range
Dim cell As Range

Set myRange = Selection

For Each cell In myRange
If WorksheetFunction.CountIf(myRange, cell.Value) > 1 Then
cell.Interior.ColorIndex = 36
End If
Next cell
End Sub

39. Làm nổi bật sự khác nhau giữa 2 cột hoặc 2 dòng
Sử dụng mã này bạn có thể làm nổi bật sự khác biệt giữa 2 cột (các ô tương ứng).

Sub columnDifference()
Range("D7:D17,E7:E17").Select
Selection.ColumnDifferences(ActiveCell).Select
Selection.Style = "Bad"
End Sub

Sử dụng mã này bạn có thể làm nổi bật sự khác nhau giữa 2 hàng (các ô tương ứng).

Sub rowDifference()
Range("D7:D17,E7:E17").Select
Selection.RowDifferences(ActiveCell).Select
Selection.Style = "Good"
End Sub

40. Hiển thị chi tiết nội dung tất cả các Comments vào trong trang in
Sử dụng mã macro sau nhằm kích hoạt cài đặt để in (cell comments) ở cuối trang. Ví dụ: tổng số trang phải in là 1 trang. Sau khi sử dụng mã này bạn sẽ nhận được tất cả comments từ trang thứ 2.

Sub printComments()
With ActiveSheet.PageSetup
.printComments = xlPrintSheetEnd
End With
End Sub

41. Định dạng căn lề trang trước khi in
Sử dụng mã VBA này để in giấy có lề hẹp. Khi bạn chạy mã macro này, mã sẽ tự động thay đổi lề thành hẹp.

Sub printNarrowMargin()
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
End With
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
End Sub

42. Print tùy chỉnh từ trang, đến trang
Thay vì sử dụng cài đặt từ print options, bạn có thể sử dụng mã này để in phạm vi trang điều chỉnh.
Ví dụ: bạn muốn từ trang 5 đến trang10. Bạn chỉ cần chạy mã VBA này và nhập trang bắt đầu và trang kết thúc.

Sub printCustomSelection()
Dim startpage As Integer
Dim endpage As Integer
startpage = InputBox("Please Enter Start Page number.", "Enter Value ")
If Not WorksheetFunction.IsNumber(startpage) Then
MsgBox "Invalid Start Page number. Please try again.", "Error"
Exit Sub
End If
endpage = InputBox("Please Enter End Page number.", "Enter Value ")
If Not WorksheetFunction.IsNumber(endpage) Then
MsgBox "Invalid End Page number. Please try again.", "Error"
Exit Sub
End If
Selection.PrintOut From:=startpage, To:=endpage, Copies:=1, Collate:=True
End Sub

43. Tùy chỉnh kích cỡ tất cả các biểu đồ về cùng kích thước
Mã macro này sẽ giúp bạn tạo tất cả các chart có chung kích cỡ. Bạn có thể thay đổi chiều cao và chiều rộng của Chart bằng cách thay đổi nó trong mã macro.

Sub Resize_Charts()
Dim i As Integer
For i = 1 To ActiveSheet.ChartObjects.Count
With ActiveSheet.ChartObjects(i)
.Width = 300
.Height = 200
End With
Next i
End Sub

44. Chèn tự động khung thời gian 24 giờ trong ngày

Với mã này, bạn có thể chèn phạm vi thời gian theo thứ tự từ 00:00 đến 23:00.

Sub TimeStamp()
Dim i As Integer
For i = 1 To 24
ActiveCell.FormulaR1C1 = i & ":00"
ActiveCell.NumberFormat = "[$-409]h:mm AM/PM;@"
ActiveCell.Offset(RowOffset:=1, ColumnOffset:=0).Select
Next i
End Sub

45. Chuyển đổi ngày tháng năm sang ngày (chỉ lấy giá trị ngày)
Nếu trong worksheet của bạn có dates và bạn muốn chuyển đổi tất cả các dates sang days. Bạn có thể sử dụng mã này. Đơn giản chỉ cần chọn phạm vi các ô và chạy mã này.

Sub dateToday()
Dim tempCell As range
Selection.Value = Selection.Value
For Each tempCell In Selection
If IsDate(tempCell) = True Then
With tempCell
.Value = Day(tempCell)
.NumberFormat = "00"
End With
End If
Next tempCell
End Sub

Tương tự, bạn cũng có thể chuyển đổi tất cả các dates sang month hoặc year

Sub dateToMonth()
Dim tempCell As range
Selection.Value = Selection.Value
For Each tempCell In Selection
If IsDate(tempCell) = True Then
With tempCell
.Value = Month(tempCell)
.NumberFormat = "00"
End With
End If
Next tempCell
End Sub

Sub dateToYear()
Dim tempCell As range
Selection.Value = Selection.Value
For Each tempCell In Selection
If IsDate(tempCell) = True Then
With tempCell
.Value = Year(tempCell)
.NumberFormat = "00"
End With
End If
Next tempCell
End Sub

46. Loại bỏ thời gian trong ô chứa thời gian và ngày tháng
Bạn có thể sử dụng mã này nếu trong worksheet có hiển thị thời gian cùng với ngày và bạn muốn xóa thời gian đi.

Sub removeTime()
Dim Rng As range
For Each Rng In Selection
If IsDate(Rng) = True Then
Rng.Value = VBA.Int(Rng.Value)
End If
Next
Selection.NumberFormat = "dd/mm/yyyy"
End Sub

Nếu bạn muốn xóa ngày đi, chỉ giữ lại thời gian thì đoạn mã sau sẽ xử lý việc đó.

Sub removeDate()
Dim Rng As range
For Each Rng In Selection
If IsDate(Rng) = True Then
Rng.Value = Rng.Value - VBA.Fix(Rng.Value)
End If
Next
Selection.NumberFormat = "hh:mm:ss am/pm"
End Sub

47. Ẩn tất cả các sheet, ngoại trừ sheet hiện hành

Ví dụ bạn muốn ẩn tất cả các worksheets trong workbook của bạn ngoài worksheet đang hoạt động. Mã macro sau sẽ giúp bạn làm điều này.

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

48. Hiển thị tất cả các sheet đã ẩn trong workbook
Mã này dành cho việc nếu bạn muốn hiển thị tất cả các sheet có trong file mà bạn đã ẩn trước đó.

Sub UnhideAllWorksheet()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Visible = xlSheetVisible
Next ws
End Sub

49. Tạo mật mã khóa bảo vệ worksheet
Đây là mã dành cho bạn nếu bạn muốn protect tất cả các worksheet chỉ trong một lần. Khi chạy mã macro này, bạn sẽ nhận được một input box để nhập password. Sau khi nhập password, click OK.

Sub ProtectAllWorskeets()
Dim ws As Worksheet
Dim ps As String
ps = InputBox("Enter a Password.", vbOKCancel)
For Each ws In ActiveWorkbook.Worksheets
ws.Protect Password:=ps
Next ws
End Sub

Macro này sẽ bảo vệ tất cả các trang tính trong một sổ làm việc.

' Protect All Worksheets
Sub ProtectAllSheets()
Dim ws As Worksheet

For Each ws In Worksheets
ws.Protect "password"
Next ws

End Sub

Còn nếu chỉ muốn protect sheet hiện hành, bạn có thể sử dụng mã này. Bạn chỉ cần nhập password của bạn vào trong đoạn mã.

Sub ProtectWS()
ActiveSheet.Protect "mypassword", True, True
End Sub

Ngược lại, nếu không muốn protect sheet bạn nhập đoạn mã sau.

Sub UnprotectWS()
ActiveSheet.Unprotect "mypassword"
End Sub

50. Chèn nhiều sheet cùng lúc chỉ trong một bước
Bạn có thể sử dụng mã này nếu bạn muốn thêm nhiều worksheet trong workbook của bạn chỉ trong một bước.
Khi bạn chạy mã macro này, bạn sẽ nhận được input box để nhập tổng số sheet mà bạn muốn nhập.

Sub InsertMultipleSheets()
Dim i As Integer
i = InputBox("Enter number of sheets to insert.", "Enter
Multiple Sheets")
Sheets.Add After:=ActiveSheet, Count:=i
End Sub

51. Sắp xếp lại thứ tự các worksheets theo tên
Mã này sẽ giúp bạn sắp xếp worksheets trong workbook dựa vào tên của worksheet.

Sub SortWorksheets()
Dim i As Integer
Dim j As Integer
Dim iAnswer As VbMsgBoxResult
iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) _
& "Clicking No will sort in Descending Order", _
vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets ")
For i = 1 To Sheets.Count
For j = 1 To Sheets.Count - 1
If iAnswer = vbYes Then
If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
ElseIf iAnswer = vbNo Then
If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
End If
Next j
Next i
End Sub

52. Xóa tất cả các sheet rỗng (không có nội dung)
Chạy mã này và mã sẽ kiểm tra tất cả các worksheets trong workbook đang hoạt động và xóa chúng nếu là một worksheet trống rỗng.

Sub deleteBlankWorksheets()
Dim Ws As Worksheet
On Error Resume Next
Application.ScreenUpdating= False
Application.DisplayAlerts= False
For Each Ws In Application.Worksheets
If Application.WorksheetFunction.CountA(Ws.UsedRange) = 0 Then
Ws.Delete
End If
Next
Application.ScreenUpdating= True
Application.DisplayAlerts= True
End Sub

53. Lưu từng sheet thành từng file định dạng PDF
Đoạn mã này chỉ đơn giản là lưu từng worksheet thành một tệp PDF riêng. Bạn có thể thay đổi tên tệp từ mã này.

Sub SaveWorkshetAsPDF()
Dim ws As Worksheet
For Each ws In Worksheets
ws.ExportAsFixedFormat xlTypePDF, "pvdoffice" & ws.Name & ".pdf"
Next ws
End Sub

54. Sao chép worksheet hiện hành sang một workbook mới
Nếu bạn muốn sao chép worksheet đang hoạt động vào một workbook mới, bạn chỉ cần chạy mã macro và mã sẽ thực hiện việc đó cho bạn.
Điều này tiết kiệm rất nhiều thời gian.

Sub CopyWorksheetToNewWorkbook()
ThisWorkbook.ActiveSheet.Copy _
Before:=Workbooks.Add.Worksheets(1)
End Sub

55. Liệt kê danh sách tất cả các trang tính trong sổ làm việc
Macro này sẽ liệt kê tất cả các trang tính có trong trong sổ làm việc.

Sub ListSheets()
Dim ws As Worksheet
Dim x As Integer
x = 1
ActiveSheet.Range("C:C").Clear
For Each ws In Worksheets
ActiveSheet.Cells(x, 3) = ws.Name
x = x + 1
Next ws
End Sub

56. Sao chép và dán một hàng từ trang tính này sang trang tính khác
Macro siêu đơn giản này sẽ sao chép một hàng từ trang tính này sang trang tính khác

Sub Paste_OneRow()
'Copy and Paste Row
Sheets("sheet1").Range("1:1").Copy Sheets("sheet2").Range("1:1")

Application.CutCopyMode = False

End Sub

57. Đếm số workbook chưa được lưu (File > Save)

Ví dụ: bạn đang mở 5-10 workbook, bạn có thể sử dụng mã này để biết được số workbook chưa được lưu.

Sub VisibleWorkbooks()
Dim book As Workbook
Dim i As Integer
For Each book In Workbooks
If book.Saved = False Then
i = i + 1
End If
Next book
MsgBox i
End Sub

58. Làm mới dữ liệu (Refesh)

Trong Excel, Power Query cập nhật khi chúng ta bấm vào nút Refresh trong thẻ Data. Điều này chỉ làm mới dữ liệu cập nhật tại thời điểm đó. Tuy nhiên, có nhiều tình huống mà chúng ta muốn Power Query tự động làm mới. Code sau sẽ giúp chúng ta giải quyết vấn đề:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim MonitorRange As Range
Set MonitorRange = Me.Range("B5,B6:C13,Data")
If Not Application.Intersect(MonitorRange, Target) Is Nothing Then
ThisWorkbook.Connections("Query - Data").Refresh
End If
End Sub

Sub RefreshQueries()
ThisWorkbook.RefreshAll
End Sub

Sub RefreshQueries()
ThisWorkbook.Connections("Query - Data").Refresh
End Sub

59. Tạo nhanh email outlook gửi đi và đính kèm workbook hiện hành vào mail
Sử dụng mã macro này để gửi Active Workbook của bạn bằng email outlook một cách nhanh chóng. Bạn có thể thay đổi tên, email, nội dung trong mã và nếu bạn muốn gửi trực tiếp email này, sử dụng “.Send” thay vì “.Display”.

Sub Send_Mail()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = "pvdofficeman@gmail.com"
.Subject = "HR Report"
.Body = "Hello, Please find attached HR Report."
.Attachments.Add ActiveWorkbook.FullName
.display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Nếu bạn chỉ cần đính kèm Active Workbook của bạn vào email outlook, thì sử dụng đoạn mã sau.

Sub OpenWorkbookAsAttachment()
Application.Dialogs(xlDialogSendMail).Show
End Sub

60. Tạo thư mục với VBA

Trong bài này, chúng ta sẽ thực hiện một dự án nhỏ để tạo một công cụ tạo thư mục. Với VBA, chúng ta có thể tạo một thư mục chỉ bằng một dòng mã.

Option Explicit
Sub CreateFolders()
MkDir "E:\pvdoffice\"
End Sub

Tạo nhiều thư mục dựa trên các ô đã chọn: thay vì sử dụng một ô duy nhất, hãy tạo một vòng lặp để chúng ta có thể tạo thư mục cho mỗi ô trong vùng chọn.

Sub CreateFolders()
On Error Resume Next
Dim c As Range
For Each c In Selection
MkDir c
Next c
On Error GoTo 0
End Sub

61. Delete pictures, shapes trong bảng tính
Trong một bảng tính excel có nhiều hình vẽ, hình ảnh khác nhau (mũi tên, hộp văn bản, hình elip, v.v.) . Làm thế nào để xóa tất cả chúng với một lần thao tác. Đoạn code sau sẽ giúp chúng ta giải quyết vấn đề:

Sub DeleteAllShapes()
Dim Shp As Shape
For Each Shp In ActiveSheet.Shapes
Shp.Delete
Next Shp
End Sub

Sub DeleteAllPictures()
Dim sh As Worksheet
For Each sh In ThisWorkbook.Worksheets
sh.Pictures.Delete
Next
End Sub

Sub DeleteAllShapes()
Dim GetShape As Shape
For Each GetShape In ActiveSheet.Shapes
GetShape.Delete
Next
End Sub

62. Xóa clipboard trong Excel
Để xóa clipboard, bạn có thể sử dụng đoạn mã bên dưới và chạy Sub TestClipboardClear để xóa clipboard của Windows

Option Explicit
Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As LongPtr
Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As LongPtr
Public Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr

Public Function ClearClipboard()
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
End Function

Sub TestClipboardClear()
Call ClearClipboard
End Sub