Top 100 mã Excel VBA Macros hữu dụng
8/28/2019
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 CODEAdd 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
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
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
Auto Fit Columns [tự động canh các cột]
Sub AutoFitColumns[]
Cells.Select
Cells.EntireColumn.AutoFit
End Sub
Auto Fit Rows [tự động canh các dòng]
Sub AutoFitRows[]
Cells.Select
Cells.EntireRow.AutoFit
End Sub
Remove Text Wrap [bỏ chế độ wrap text]
Sub RemoveWrapText[]
Cells.Select
Selection.WrapText = False
Cells.EntireRow.AutoFit
Cells.EntireColumn.AutoFit
End Sub
Unmerge Cells [không kết nối các ô]
Sub UnmergeCells[]
Selection.UnMerge
End Sub
Open Calculator [mở máy tính trên excel]
Sub OpenCalculator[]
Application.ActivateMicrosoftApp Index:=0
End Sub
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
Custom Header/Footer [chèn đầu trang/chân trang theo ý bạn]
Formatting Codes
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
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
Highlight the Active Row and Column
Mở VBE [ALT + F11]. Di chuyển đến Project Explorer [Crtl + R, If hidden]. 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. Dán mã vào đó và chọn BeforeDoubleClick từ [event drop down menu]. Đó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
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
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
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
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
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
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
Highlight Cells with Comments
Sub highlightCommentCells[]
Selection.SpecialCells[xlCellTypeComments].Select
Selection.Style= "Note"
End Sub
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
Highlight 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
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
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
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
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
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
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
Highlight Difference in Columns
Sub columnDifference[]
Range["H7:H8,I7:I8"].Select
Selection.ColumnDifferences[ActiveCell].Select
Selection.Style= "Bad"
End Sub
Highlight Difference in Rows
Sub rowDifference[]
Range["H7:H8,I7:I8"].Select
Selection.RowDifferences[ActiveCell].Select
Selection.Style= "Bad"
End Sub
Print Comments
Sub printComments[]
With ActiveSheet.PageSetup
.printComments= xlPrintSheetEnd
End With
End Sub
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
Print Selection
Sub printSelection[]
Selection.PrintOutCopies:=1, Collate:=True
End Sub
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
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
Unhide all Hidden Worksheets
Sub UnhideAllWorksheet[]
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Visible = xlSheetVisible
Next ws
End Sub
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
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
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
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
Protect worksheet
Sub ProtectWS[]
ActiveSheet.Protect "mypassword", True, True
End Sub
Un-Protect Worksheet
Sub UnprotectWS[]
ActiveSheet.Unprotect "mypassword"
End Sub
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
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
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
Unhide all Rows and Columns
Sub UnhideRowsColumns[]
Columns.EntireColumn.Hidden = False
Rows.EntireRow.Hidden = False
End Sub
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
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
Create a Backup of a Current Workbook
Sub FileBackUp[]
ThisWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & _
"" & Format[Date, "mm-dd-yy"] & " " & _
ThisWorkbook.name
End Sub
Close all Workbooks at Once
Sub CloseAllWorkbooks[]
Dim wbs As Workbook
For Each wbs In Workbooks
wbs.Close SaveChanges:=True
Next wb
End Sub
Copy Active Worksheet into a New Workbook
Sub CopyWorksheetToNewWorkbook[]
ThisWorkbook.ActiveSheet.Copy _
Before:=Workbooks.Add.Worksheets[1]
End Sub
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 = ""
.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
Add Workbook to a Mail Attachment
Sub OpenWorkbookAsAttachment[]
Application.Dialogs[xlDialogSendMail].Show
End Sub
Welcome Message
Sub auto_open[]
MsgBox "Welcome To ExcelChamps & Thanks for downloading this
file."
End Sub
Closing Message
Sub auto_close[]
MsgBox "Bye Bye! Don't forget to check other cool stuff on
excelchamps.com"
End Sub
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
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
Refresh All Pivot Tables
Sub CloseAllWorkbooks[]
Dim wbs As Workbook
For Each wbs In Workbooks
wbs.Close SaveChanges:=True
Next wb
End Sub
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
Disable/Enable Get Pivot Data
Sub activateGetPivotData[]
Application.GenerateGetPivotData = True
End Sub
Sub deactivateGetPivotData[]
Application.GenerateGetPivotData = False
End Sub
Change Chart Type
Sub ChangeChartType[]
ActiveChart.ChartType = xlColumnClustered
End Sub
Paste Chart as an Image
Sub ConvertChartToPicture[]
ActiveChart.ChartArea.Copy
ActiveSheet.Range["A1"].Select
ActiveSheet.Pictures.Paste.Select
End Sub
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
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
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
Convert Range into an Image
Sub PasteAsPicture[]
Application.CutCopyMode = False
Selection.Copy
ActiveSheet.Pictures.Paste.Select
End Sub
Insert a Linked Picture
Sub LinkedPicture[]
Selection.Copy
ActiveSheet.Pictures.Paste[Link:=True].Select
End Sub
Use Text to Speech
Sub Speak[]
Selection.Speak
End Sub
Activate Data Entry Form
Sub DataForm[]
ActiveSheet.ShowDataForm
End Sub
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
VBA 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 //google.com/#q=" & search_string]
End Sub
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
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
Remove Characters from a String
Public Function removeFirstC[rng As String, cnt As Long]
removeFirstC = Right[rng, Len[rng] - cnt]
End Function
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
Reverse Text
Public Function rvrse[ByVal cell As Range] As String
rvrse = VBA.strReverse[cell.Value]
End Function
Activate R1C1 Reference Style
Sub DataForm[]
ActiveSheet.ShowDataForm
End Sub
Activate A1 Reference Style
Sub ActivateA1[]
If Application.ReferenceStyle = xlR1C1 Then
Application.ReferenceStyle = xlA1
Else
Application.ReferenceStyle = xlA1
End If
End Sub
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
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
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
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
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
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
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
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
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
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
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
Remove the Apostrophe from a Number
Sub removeApostrophes[]
Selection.Value = Selection.Value
End Sub
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
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
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
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
Calculate 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
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
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
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
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 Sub
Theo: Excel Champ