Sub upper()
For Each cell In Selection If Not cell.HasFormula Then cell.Value = UCase(cell.Value) End If Next cell End Sub Sub proper() For Each cell In Selection If Not cell.HasFormula Then cell.Value = Application.WorksheetFunction.proper(cell.Value) End If Next cell End Sub Sub lower() For Each cell In Selection If Not cell.HasFormula Then cell.Value = LCase(cell.Value) End If Next cell End Sub
Jameen kharidne se pahle ye jankari hasil kare
https://youtu.be/ve9baM9cr8k
Jameen kharidne aur bechne se pahle iski jankari hasil kar le nahi to jameen hath se ja sakti he
https://youtu.be/X5GFIrKmCik
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
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
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
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
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
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
: 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
Use Text to Speech
Sub Speak()
Selection.Speak
End Sub
Activate Data Entry
Form
Sub DataForm()
ActiveSheet.ShowDataForm
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 http://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
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.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
INSERT LINK PICTURE
Sub LinkedPicture()
Selection.Copy
ActiveSheet.Pictures.Paste(Link:=True).Select
End Sub
REFRESH ALL PIVOT TABLE
Sub vba_referesh_all_pivots()
Dim pt As PivotTable
For Each pt In
ActiveWorkbook.PivotTables
pt.RefreshTable
Next pt
End Sub
ACTIVE GET PIVOT TABLE
Sub
activateGetPivotData()
Application.GenerateGetPivotData
= True
End Sub
Sub
deactivateGetPivotData()
Application.GenerateGetPivotData
= False
End Sub
HIDE SUBTOTAL
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
OPEN WORKBOOK AS ATTACHMENT
Sub
OpenWorkbookAsAttachment()
Application.Dialogs(xlDialogSendMail).Show
End Sub
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
SEND MAIL ON OUTLOOK
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
SAVE WORKSHEET AS PDF
Sub
SaveWorkshetAsPDF()
Dimws As Worksheet
For Each ws In
Worksheets
ws.ExportAsFixedFormat
_
xlTypePDF, _
"ENTER-FOLDER-NAME-HERE"
& _
ws.Name &
".pdf"
Next ws
End Sub
COPY WORKBOOK TO NEW WORKBOOK
Sub
CopyWorksheetToNewWorkbook()
ThisWorkbook.ActiveSheet.Copy
_
Before:=Workbooks.Add.Worksheets(1)
End Sub
LOCK CELL WITH FORMULAS
Sub lockCellsWithFormulas()
With ActiveSheet
.Unprotect
.Cells.Locked = False
.Cells.SpecialCells(xlCellTypeFormulas).Locked = True
.Protect AllowDeletingRows:=True
End With
End Sub
DELETE BALANK WORKSHEET
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
PROTECT SHEET WITH PASSWORD
Sub ProtectWS()
ActiveSheet.Protect "mypassword", True, True
End Sub
SORT 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
DELETE 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 WORKSHEET
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
SELECT PRINT AREA
Sub printSelection()
Selection.PrintOut Copies:=1, Collate:=True
End Sub
HIDE 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 WORKSHEET
Sub UnhideAllWorksheet()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Visible = xlSheetVisible
Next ws
End Sub
Sub columnDifference()
Range("H7:H8,I7:I8").Select
Selection.ColumnDifferences(ActiveCell).Select
Selection.Style= "Bad"
End Sub
PRINT COMMENT
Sub printComments()
With ActiveSheet.PageSetup
.printComments = xlPrintSheetEnd
End With
End Sub
[10:24 AM, 12/18/2020] Aakash: 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
highlight greather than value
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 negetive mark
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
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 range
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
heighlight dublicate valuele
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
set custom header
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
remove text wrap
Sub RemoveTextWrap()
Range("A1").WrapText = False
End Sub
unmerge cell
Sub UnmergeCells()
Selection.UnMerge
End Sub
open calculator
Sub OpenCalculator()
Application.ActivateMicrosoftApp Index:=0
End Sub
date in header setup
Sub DateInHeader()
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "&D"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
End With
End Sub
autofit column 1 st coading
Sub AutoFitColumns()
Cells.Select
Cells.EntireColumn.AutoFit
End Sub
autofit row 2nd coading
Sub AutoFitRows()
Cells.Select
Cells.EntireRow.AutoFit
End Sub
insert row as per your requirement
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
add columns as per your requirement
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 serial no as per your requirement
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
