Top 100 mã Excel VBA Macros hữu dụng

• Di chuyển đến developer tab của bạn và nhấp chọn “Visual Basic”.

• Phía bên trái trên “Project Window”, nhấp chuột phải vào tên workbook của bạn và chèn vào một module mới.

• Dán mã code của bạn vào trong module đó và đóng lại.

• Bây giờ, di chuyển đến developer tab và nhấp chuột vào Macro.

• Macro sẽ hiển thị một cửa sổ danh sách các macro có trong tệp của bạn, từ đó bạn có thể chạy các macro có trong danh sách đó.

Basic Formatting Printing

Worksheet Workbook Pivot Table

Charts Advanced Formulas

BASIC CODE

1. Add Serial Numbers (đánh số thự tự tự động)

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. Add Multiple Columns (chèn cột)

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

3. Add Multiple Rows (chèn dòng)

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                 

4. Auto Fit Columns (tự động canh các cột)

Sub AutoFitColumns()

Cells.Select

Cells.EntireColumn.AutoFit

End Sub

5. Auto Fit Rows (tự động canh các dòng)

Sub AutoFitRows()

Cells.Select

Cells.EntireRow.AutoFit

End Sub

6. Remove Text Wrap (bỏ chế độ wrap text)

Sub RemoveWrapText()

Cells.Select

Selection.WrapText = False

Cells.EntireRow.AutoFit

Cells.EntireColumn.AutoFit

End Sub

7. Unmerge Cells (không kết nối các ô)

Sub UnmergeCells()

Selection.UnMerge

End Sub

8. Open Calculator (mở máy tính trên excel)

Sub OpenCalculator()

Application.ActivateMicrosoftApp Index:=0

End Sub

9. Add Header/Footer Date (thêm ngày ở chân trang/đầu trang)

Sub dateInHeader()

With ActiveSheet.PageSetup

.LeftHeader = “”

.CenterHeader = “&D”

.RightHeader = “”

.LeftFooter = “”

.CenterFooter = “”

.RightFooter = “”

End With

ActiveWindow.View = xlNormalView

End Sub

10. Custom Header/Footer (chèn đầu trang/chân trang theo ý bạn)

Sub customHeader()

Dim myText As Stringmy

Text = InputBox(“Enter your text here”, “Enter Text”)

With ActiveSheet.PageSetup

.LeftHeader = “”

.CenterHeader = myText

.RightHeader = “”

.LeftFooter = “”

.CenterFooter = “”

.RightFooter = “”

End With

End Sub 

Formatting Codes

11. Highlight Duplicates from Selection (tô màu các ô cùng giá trị trong vùng được chọn)

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

12. Highlight the Active Row and Column

1. Mở VBE (ALT + F11).
2. Di chuyển đến Project Explorer (Crtl + R, If hidden).
3. Chọn workbook của bạn và nhấp đúp chuột vào tên một worksheet cụ thể mà bạn muốn kích hoạt mã macro.
4. Dán mã vào đó và chọn “BeforeDoubleClick” từ (event drop down menu).
5. Đóng VBE và bạn đã hoàn thành.

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

13. Highlight Top 10 Values

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

14. Highlight Named Ranges

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 = 36

Next RangeName

End Sub

15. Highlight Greater than Values

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).S

tFirstPriority

With Selection.FormatConditions(1)

.Font.Color = RGB(0, 0, 0)

.Interior.Color = RGB(31, 218, 154)

End With

End Sub

16. Highlight Lower than Values

Sub HighlightLowerThanValues()

Dim i As Integer

i = InputBox(“Enter Lower Than Value”, “Enter Value”)

Selection.FormatConditions.Delete

Selection.FormatConditions.Add Type:=xlCellValue,

Operator:=xlLower, Formula1:=i

Selection.FormatConditions(Selection.FormatConditions.Count).S

tFirstPriority

With Selection.FormatConditions(1)

.Font.Color = RGB(0, 0, 0)

.Interior.Color = RGB(217, 83, 79)

End With

End Sub

17. Highlight 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

18. Highlight Specific Text

Sub highlightValue()

Dim myStr As String

Dim myRg As Range

Dim myTxt As String

Dim myCell As Range

Dim myChar As String

Dim I As Long

Dim J As Long

On Error Resume Next

If ActiveWindow.RangeSelection.Count> 1 Then

myTxt= ActiveWindow.RangeSelection.AddressLocal

Else

myTxt= ActiveSheet.UsedRange.AddressLocal

End If

LInput: Set myRg= Application.InputBox(“please select the data

range:”, “Selection Required”, myTxt, , , , , 8)

If myRg Is Nothing Then

Exit Sub

If myRg.Areas.Count > 1 Then

MsgBox”not support multiple columns” GoToLInput

End If

If myRg.Columns.Count <> 2 Then

MsgBox”the selected range can only contain two columns “

GoTo LInput

End If

For I = 0 To myRg.Rows.Count-1

myStr= myRg.Range(“B1”).Offset(I, 0).Value

With myRg.Range(“A1”).Offset(I, 0)

.Font.ColorIndex= 1

For J = 1 To Len(.Text)

Mid(.Text, J, Len(myStr)) = myStrThen

.Characters(J, Len(myStr)).Font.ColorIndex= 3

Next

End With

Next I

End Sub

19. Highlight Cells with Comments

Sub highlightCommentCells()

Selection.SpecialCells(xlCellTypeComments).Select

Selection.Style= “Note”

End Sub

20. Highlight Alternate Rows in the Selection

Sub highlightAlternateRows()

Dim rng As Range

For Each rng In Selection.Rows

If rng.RowMod 2 = 1 Then

rng.Style= “20% -Accent1”

rng.Value= rng^ (1 / 3)

Else

End If

Next rng

End Sub

21. hlight Cells with Misspelled Words

Sub HighlightMisspelledCells()

Dim rng As Range

For Each rng In ActiveSheet.UsedRange

If Not Application.CheckSpelling(word:=rng.Text) Then

rng.Style= “Bad” End If

Next rng

End Sub

22. Highlight Cells With Error in the Entire Worksheet

Sub highlightErrors()

Dim rng As Range

Dim i As Integer

For Each rng In ActiveSheet.UsedRange

If WorksheetFunction.IsError(rng) Then

i = i + 1 rng.Style = “bad”

End If

Next rng

MsgBox “There are total ” & i & ” error(s) in this worksheet.”

End Sub

23. Highlight Cells with a Specific Text in Worksheet

Sub highlightSpecificValues()

Dim rng As Range

Dim i As Integer

Dim c As Variant

c = InputBox(“Enter Value To Highlight”)

For Each rng In ActiveSheet.UsedRange

If rng = c Then

rng.Style = “Note”

i = i + 1

End If

Next rng

MsgBox “There are total ” & i &” “& c & ” in this worksheet.”

End Sub

24. Highlight all the Blank Cells Invisible Space

Sub blankWithSpace()

Dim rng As Range

For Each rng In ActiveSheet.UsedRange

If rng.Value = ” ” Then

rng.Style = “Note”

End If

Next rng

End Sub

25. Highlight Max Value In The Range

Sub highlightMaxValue()

Dim rng As Range

For Each rng In Selection

If rng = WorksheetFunction.Max(Selection) Then

rng.Style = “Good”

End If

Next rng

End Sub

26. Highlight Min Value In The Range

Sub highlightMinValue()

Dim rng As Range

For Each rng In Selection

If rng = WorksheetFunction.Min(Selection) Then

rng.Style = “Good”

End If

Next rng

End Sub

27. Highlight Unique Values

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

28. Highlight Difference in Columns

Sub columnDifference()

Range(“H7:H8,I7:I8”).Select

Selection.ColumnDifferences(ActiveCell).Select

Selection.Style= “Bad”

End Sub

29. Highlight Difference in Rows

Sub rowDifference()

Range(“H7:H8,I7:I8”).Select

Selection.RowDifferences(ActiveCell).Select

Selection.Style= “Bad”

End Sub

Printing Codes

30. Print Comments

Sub printComments()

With ActiveSheet.PageSetup

.printComments= xlPrintSheetEnd

End With

End Sub

31. Print Narrow Margin

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.PrintOutCopies:=1, Collate:=True,

IgnorePrintAreas:=False

End Sub

32. Print Selection

Sub printSelection()

Selection.PrintOutCopies:=1, Collate:=True

End Sub

33. Print Custom Pages

Sub printCustomSelection()

Dim startpageAs Integer

Dim endpageAs 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.PrintOutFrom:=startpage, To:=endpage, Copies:=1,

Collate:=True

End Sub

Worksheet Codes

34. Hide all but the Active Worksheet

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

35. Unhide all Hidden Worksheets

Sub UnhideAllWorksheet()

Dim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets

ws.Visible = xlSheetVisible

Next ws

End Sub

36. Delete all but the Active Worksheet

Sub DeleteWorksheets()

Dim ws As Worksheet

For Each ws In ThisWorkbook.Worksheets

If ws.name <> ThisWorkbook.ActiveSheet.name Then

Application.DisplayAlerts = False

ws.Delete

Application.DisplayAlerts = True

End If

Next ws

End Sub

37. Protect all Worksheets Instantly

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

38. Resize All Charts in a Worksheet.

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

39. Insert Multiple Worksheets

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

40. Protect worksheet

Sub ProtectWS()

ActiveSheet.Protect “mypassword”, True, True

End Sub

41. Protect Worksheet

Sub UnprotectWS()

ActiveSheet.Unprotect “mypassword”

End Sub

42. Sort Worksheets

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          

43. Protect all the Cells With Formulas

Sub lockCellsWithFormulas()

With ActiveSheet

.Unprotect

.Cells.Locked = False

.Cells.SpecialCells(xlCellTypeFormulas).Locked = True

.Protect AllowDeletingRows:=True

End With

End Sub

44. Delete all Blank Worksheets

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

45. Unhide all Rows and Columns

Sub UnhideRowsColumns()

Columns.EntireColumn.Hidden = False

Rows.EntireRow.Hidden = False

End Sub

46. Save Each Worksheet as a Single PDF

Sub SaveWorkshetAsPDF()

Dimws As Worksheet

For Each ws In Worksheetsws.ExportAsFixedFormat xlTypePDF,

“ENTER-FOLDER-NAME-HERE” & ws.Name & “.pdf” Nextws

End Sub

47. Disable Page Breaks

Sub DisablePageBreaks()

Dim wbAs Workbook

Dim wksAs Worksheet

Application.ScreenUpdating= False

For Each wbIn Application.Workbooks

For Each ShtIn wb.WorksheetsSht.DisplayPageBreaks= False

Next Sht

Next wb

Application.ScreenUpdating= True

End Sub         

Workbook Codes

48. Create a Backup of a Current Workbook

Sub FileBackUp()

ThisWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & _

“” & Format(Date, “mm-dd-yy”) & ” ” & _

ThisWorkbook.name

End Sub

49. Close all Workbooks at Once

Sub CloseAllWorkbooks()

Dim wbs As Workbook

For Each wbs In Workbooks

wbs.Close SaveChanges:=True

Next wb

End Sub

50. Copy Active Worksheet into a New Workbook

Sub CopyWorksheetToNewWorkbook()

ThisWorkbook.ActiveSheet.Copy _

Before:=Workbooks.Add.Worksheets(1)

End Sub

51. Active Workbook in an Email

Sub Send_Mail()

Dim OutApp As Object

Dim OutMail As Object

Set OutApp = CreateObject(“Outlook.Application”)

Set OutMail = OutApp.CreateItem(0)

With OutMail

.to = “Sales@FrontLinePaper.com”

.Subject = “Growth Report”

.Body = “Hello Team, Please find attached Growth Report.”

.Attachments.Add ActiveWorkbook.FullName

.display

End With

Set OutMail = Nothing

Set OutApp = Nothing

End Sub

52. Add Workbook to a Mail Attachment

Sub OpenWorkbookAsAttachment()

Application.Dialogs(xlDialogSendMail).Show

End Sub

53. Welcome Message

Sub auto_open()

MsgBox “Welcome To ExcelChamps & Thanks for downloading this

file.”

End Sub

54. Closing Message

Sub auto_close()

MsgBox “Bye Bye! Don’t forget to check other cool stuff on

excelchamps.com”

End Sub

55. Count Open Unsaved Workbooks

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

Pivot Table Codes

56. Hide Pivot Table Subtotals

Sub HideSubtotals()

Dim pt As PivotTable

Dim pf As PivotField

On Error Resume Next

Set pt = ActiveSheet.PivotTables(ActiveCell.PivotTable.name)

If pt Is Nothing Then

MsgBox “You must place your cursor inside of a PivotTable.”

Exit Sub

End If

For Each pf In pt.PivotFields

pf.Subtotals(1) = True

pf.Subtotals(1) = False

Next pf

End Sub

57. Refresh All Pivot Tables

Sub CloseAllWorkbooks()

Dim wbs As Workbook

For Each wbs In Workbooks

wbs.Close SaveChanges:=True

Next wb

End Sub

59. Auto Update Pivot Table Range

Sub UpdatePivotTableRange()

Dim Data_Sheet As Worksheet

Dim Pivot_Sheet As Worksheet

Dim StartPoint As Range

Dim DataRange As Range

Dim PivotName As String

Dim NewRange As String

Dim LastCol As Long

Dim lastRow As Long

‘Set Pivot Table & Source Worksheet

Set Data_Sheet = ThisWorkbook.Worksheets(“PivotTableData3”)

Set Pivot_Sheet = ThisWorkbook.Worksheets(“Pivot3”)

‘Enter in Pivot Table Name

PivotName = “PivotTable2”

‘Defining Staring Point & Dynamic Range

Data_Sheet.Activate

Set StartPoint = Data_Sheet.Range(“A1”)

LastCol = StartPoint.End(xlToRight).Column

DownCell = StartPoint.End(xlDown).Row

Set DataRange = Data_Sheet.Range(StartPoint, Cells(DownCell, LastCol))

NewRange = Data_Sheet.Name & “!” & DataRange.Address(ReferenceStyle:=xlR1C1)

‘Change Pivot Table Data Source Range Address

Pivot_Sheet.PivotTables(PivotName). _

ChangePivotCache ActiveWorkbook. _

PivotCaches.Create(SourceType:=xlDatabase, SourceData:=NewRange)

‘Ensure Pivot Table is Refreshed

Pivot_Sheet.PivotTables(PivotName).RefreshTable

‘Complete Message

Pivot_Sheet.Activate

MsgBox “Your Pivot Table is now updated.”

End Sub

60. Disable/Enable Get Pivot Data

Sub activateGetPivotData()

Application.GenerateGetPivotData = True

End Sub

Sub deactivateGetPivotData()

Application.GenerateGetPivotData = False

End Sub

Charts Codes

61. Change Chart Type

Sub ChangeChartType()

ActiveChart.ChartType = xlColumnClustered

End Sub

62. Paste Chart as an Image

Sub ConvertChartToPicture()

ActiveChart.ChartArea.Copy

ActiveSheet.Range(“A1”).Select

ActiveSheet.Pictures.Paste.Select

End Sub

63. Add Chart Title

Sub AddChartTitle()

Dim i As Variant

i = InputBox(“Please enter your chart title”, “Chart Title”)

On Error GoTo Last

ActiveChart.SetElement (msoElementChartTitleAboveChart)

ActiveChart.ChartTitle.Text = i

Last:

Exit Sub

End Sub

Advanced Codes

64. Save Selected Range as a PDF

Sub HideSubtotals()

Dim pt As PivotTable

Dim pf As PivotField

On Error Resume Next

Set pt = ActiveSheet.PivotTables(ActiveCell.PivotTable.n ame)

If pt Is Nothing Then

MsgBox “You must place your cursor inside of a PivotTable.”

Exit Sub

End If

For Each pf In pt.PivotFields

pf.Subtotals(1) = True

pf.Subtotals(1) = False

Next pf

End Sub

65. Create a Table of Content

Sub TableofContent()

Dim i As Long

On Error Resume Next

Application.DisplayAlerts = False

Worksheets(“Table of Content”).Delete

Application.DisplayAlerts = True

On Error GoTo 0

ThisWorkbook.Sheets.Add Before:=ThisWorkbook.Worksheets(1)

ActiveSheet.Name = “Table of Content”

For i = 1 To Sheets.Count

With ActiveSheet

.Hyperlinks.Add _

Anchor:=ActiveSheet.Cells(i, 1), _

Address:=””, _

SubAddress:=”‘” & Sheets(i).Name & “‘!A1”, _

ScreenTip:=Sheets(i).Name, _

TextToDisplay:=Sheets(i).Name

End With

Next i

End Sub

66. Convert Range into an Image

Sub PasteAsPicture()

Application.CutCopyMode = False

Selection.Copy

ActiveSheet.Pictures.Paste.Select

End Sub

67. Insert a Linked Picture

Sub LinkedPicture()

Selection.Copy

ActiveSheet.Pictures.Paste(Link:=True).Select

End Sub

68. Use Text to Speech

Sub Speak()

Selection.Speak

End Sub

69. Activate Data Entry Form

Sub DataForm()

ActiveSheet.ShowDataForm

End Sub

70. Use Goal Seek

Sub GoalSeekVBA()

Dim Target As Long

On Error GoTo Errorhandler

Target = InputBox(“Enter the required value”, “Enter Value”)

Worksheets(“Goal_Seek”).Activate

With ActiveSheet .Range(“C7”)

.GoalSeek_ Goal:=Target, _

ChangingCell:=Range(“C2”)

End With

Exit Sub

Errorhandler: MsgBox(“Sorry, value is not valid.”)

End Sub

71.  Code to Search on Google

Sub SearchWindow32()

Dim chromePath As String

Dim search_string As String

Dim query As String

query = InputBox(“Enter here your search here”, “Google Search”)

search_string = query

search_string = Replace(search_string, ” “, “+”)

‘Uncomment the following line for Windows 64 versions and comment out Windows 32 versions’

chromePath = “C:Program

FilesGoogleChromeApplicationchrome.exe”

‘Uncomment the following line for Windows 32 versions and comment out Windows 64 versions

chromePath = “C:Program Files

(x86)GoogleChromeApplicationchrome.exe”

Shell (chromePath & ” -url http://google.com/#q=” & search_string)

End Sub

Formula Codes

72.  Convert all Formulas into 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

73. Remove Spaces from Selected Cells

Sub RemoveSpaces()

Dim myRange As Range

Dim myCell As Range

Select Case MsgBox(“You Can’t Undo This Action. ” & “Save

Workbook First?”, _

vbYesNoCancel, “Alert”)

Case Is = vbYesThisWorkbook.Save

Case Is = vbCancel

Exit Sub

End Select

Set myRange = Selection

For Each myCell In myRange

If Not IsEmpty(myCell) Then

myCell = Trim(myCell)

End If

Next myCell

End Sub

74. Remove Characters from a String

Public Function removeFirstC(rng As String, cnt As Long)

removeFirstC = Right(rng, Len(rng) – cnt)

End Function

75. Add Insert Degree Symbol in Excel

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 & “°”

End If

End If

Next

End Sub

76. Reverse Text

Public Function rvrse(ByVal cell As Range) As String

rvrse = VBA.strReverse(cell.Value)

End Function

77. Activate R1C1 Reference Style

Sub DataForm()

ActiveSheet.ShowDataForm

End Sub

78. Activate A1 Reference Style

Sub ActivateA1()

If Application.ReferenceStyle = xlR1C1 Then

Application.ReferenceStyle = xlA1

Else

Application.ReferenceStyle = xlA1

End If

End Sub

79. Insert Time Range

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

80. Convert Date into Day

Sub date2day()

Dim tempCell As Range

Selection.Value = Selection.Value

For Each tempCell In Selection

If IsDate(tempCell) = True Then

With tempCell

.Value = Day(tempCell)

.NumberFormat = “0”

End With

End If

Next tempCell

End Sub

81. Convert Date into Year

Sub date2year()

Dim tempCell As Range

Selection.Value = Selection.Value

For Each tempCell In Selection

If IsDate(tempCell) = True Then

With tempCell

.Value = Year(tempCell)

.NumberFormat = “0”

End With

End If

Next tempCell

End Sub

82. Remove Time from Date

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-mmm-yy”

End Sub

83. Remove Date from Date and Time

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

NextSelection.NumberFormat = “hh:mm:ss am/pm”

End Sub

84. Convert to Upper Case

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

85. Convert to Lower Case

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

86. Convert to Proper Case

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

87. Convert to Sentence Case

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

88. Remove a Character form Selection

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

89. Word Count from Entire 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

90. ove the Apostrophe from a Number

Sub removeApostrophes()

Selection.Value = Selection.Value

End Sub

91. Remove Decimals from Numbers

Sub removeDecimals()

Dim lnumber As Double

Dim lResult As Long

Dim rng As Range

For Each rng In Selection

rng.Value= Int(rng)

rng.NumberFormat= “0”

Next rng

End Sub

92. Multiply all the Values by a Number

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

93. Add a Number in all the Numbers

Sub addNumber()

Dim rngAs Range

DimiAs 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

94. Calculate the Square Root

Sub getSquareRoot()

Dim rngAs 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

95. ulate the Cube Root

Sub getCubeRoot()

Dim rng As Range

Dimi As Integer

For Each rng In Selection

If WorksheetFunction.IsNumber(rng) Then

rng.Value = rng ^ (1 / 3)

Else

End If

Nextrng

End Sub

96. Add A-Z Alphabets in a Range

Sub addcAlphabets()

Dim i As Integer

For i= 65 To 90

ActiveCell.Value= Chr(i)

ActiveCell.Offset(1, 0).Select

Next i

End Sub

Sub addsAlphabets()

Dim i As Integer

For i= 97 To 122

ActiveCell.Value= Chr(i)

ActiveCell.Offset(1, 0).Select

Next i

End Sub

97. Convert Roman Numbers into Arabic Numbers

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

98. Remove Negative Signs

Sub removeNegativeSign()

Dim rngAs Range

Selection.Value= Selection.Value

For Each rngIn Selection

If WorksheetFunction.IsNumber(rng)

Then rng.Value= Abs(rng)

End If

Next rng

End Sub

99. Replace Blank Cells with Zeros

Sub replaceBlankWithZero()

Dim rngAs Range

Selection.Value= Selection.Value

For Each rngIn Selection

If rng= “” Or rng= ” ” Then

rng.Value= “0”

Else

End If

Next rng

End S

#quantriexcel #kynangmoi

DienDan.Edu.Vn Cám ơn bạn đã quan tâm và rất vui vì bài viết đã đem lại thông tin hữu ích cho bạn.
DienDan.Edu.Vn! là một website với tiêu chí chia sẻ thông tin,... Bạn có thể nhận xét, bổ sung hay yêu cầu hướng dẫn liên quan đến bài viết. Vậy nên đề nghị các bạn cũng không quảng cáo trong comment này ngoại trừ trong chính phần tên của bạn.
Cám ơn.