exshail - Vba Codes

UDF to put Sheet name in a Cell.

Formula to get sheet name in cell.
1. Formula to get sheet name in cell.
2. Function GetShtName()
3. With Application
4. .Volatile (True)
5. GetShtName = .Caller.Parent.Name
6. End With
7. End Function
8. In any cell (e.g. A1) type below formula (Copy formula to other sheets)
9. =GetShtName()
10. Go Top

To Show Sheet Activate Dialogbox

When there is a lots of sheets & you want easy navigation use this methods.
1. Find inbuilt control for sheet activate & execute.
Sub moresheets()
CommandBars.FindControl(Type:= _
msoControlButton, ID:=957).Execute
End Sub
2. Run this macro to add control to standard toolbar &
afterword you have to click this button to activate dialog.
Sub AddControl()
'add button to commandbar for sheet activate dialogbox.
Set cnt = CommandBars("Standard").Controls.Add _
(Type:=msoControlButton, before:=1, ID:=957)
End Sub
3. Using sendkeys: More then 16 sheet then show activate
dialogbox else popup sheet name.
Sub SheetActivate()
'assigne shortcut Key
If Application.CommandBars("workbook tabs").Controls
(16).Caption Like "More Sheets*" Then
Application.SendKeys "{end}~"
Application.CommandBars("workbook tabs").ShowPopup
End Sub
Go Top

Position Custom Toolbar to Next of another Toolbar:

'Move Custom/InBuilt Toolbar on the screen Next to desired Toolbar.
Sub test()
'Positionnext(source,destination)
PositionNext "mytoolbarname", "standard"
End Sub
Function PositionNext(Source As String, Destination As String)
'position any commandbars to be next of.
Dim DesTop As Long
Dim DesLeft As Long
Dim DesWidth As Long
Dim DesRow As Long
Dim DesPos As Long
With Application.CommandBars(Destination)
DesTop = .Top
DesLeft = .Left
DesWidth = .Width
DesRow = .RowIndex
DesPos = .Position
End With
With Application.CommandBars(Source)
.Position = DesPos
.RowIndex = DesRow
.Top = DesTop
.Left = DesLeft + DesWidth
End With
End Function
Go Top

Change Text Case in the Cells:

Change Text to UPPERCASE or Title Case or lowercase using intellisense logic.
Sub SelectCase() 'Assign Shortcut key
Dim C As Range, rng As Range, cc As Integer
If Selection.Count = 1 Then
Set rng = Activecell
Else
Set rng = Selection.SpecialCells(xlCellTypeConstants).Cells
End If
Set C = rng(1)
Select Case True
Case C = LCase(C)
cc = 1
Case C = UCase(C)
cc = 2
Case Else
cc = 3
End Select
Application.EnableCancelKey = xlErrorHandler
On Error GoTo xit
Application.EnableEvents = 0
For Each C In rng
With C
.Formula = Choose(cc, UCase(.Formula), Application.Proper(.Formula), LCase(.Formula))
End With
Next C
xit:
Application.EnableEvents = 1
End Sub
Go Top

List of Colour Index on the new Sheet

Get ColorIndex of Colors from Active Workbook.
Sub ColorList()
'Modified by Tom Ogilvy
Dim colsht As Worksheet
Dim xlcol As Integer
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Col Index List").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set colsht = Worksheets.Add
Set rng = colsht.Range("A1:G8")
With colsht
On Error Resume Next
.Name = "Col Index List"
For xlcol = 1 To 56
With rng(xlcol)
.Interior.ColorIndex = xlcol
.Value = xlcol
Select Case xlcol
Case 2, 6, 8, 19, 20, 28, 34, 35, 36, 40
.Font.ColorIndex = 1
Case Else
.Font.ColorIndex = 2
End Select
End With
Next
End With
End Sub
Go Top

Sort Sheet Tab

When there are a lots of sheets & you want to sort Sheet Tabs.
Change Worksheets to Sheets to sort all type of sheets.
Sub QuickSortSheets(Optional SortOrder)
Dim i As Long
Dim j As Long
Dim SheetsCount As Long
Dim FirstSheet As String
Dim NextSheet As String
Dim LValue As String
Dim HValue As String
Dim VTemp As String
Application.ScreenUpdating = 0
SheetsCount = Worksheets.Count
For i = 1 To SheetsCount \ 2
FirstSheet = Worksheets(i).Name
LValue = FirstSheet
HValue = FirstSheet
For j = i To SheetsCount - 1
NextSheet = Worksheets(j + 1).Name
If LValue > NextSheet Then LValue = NextSheet
If HValue < NextSheet Then HValue = NextSheet
Next
If IsMissing(SortOrder) Then
Else
VTemp = LValue
LValue = HValue
HValue = VTemp
End If
If LValue <> FirstSheet Then Worksheets(LValue).Move before:=Worksheets(i)
If HValue <> Worksheets(SheetsCount).Name Then Worksheets(HValue).Move after:=Worksheets(SheetsCount)
SheetsCount = SheetsCount - 1
Next
Application.ScreenUpdating = 1
End Sub
Go Top

Create Userform at Run-time:

Copy below code to any standard module & run macro called "Runme"
Option Explicit
Dim myform
Const bShow As Boolean = False '(True=show excel)
Sub RunMe()
'Create userform at run-time for Print Preview.
On Error GoTo PgmEnd
Application.VBE.MainWindow.Visible = False
Application.Visible = bShow
'designing UserForm1
MyForm_Create
MyForm_Controls_Create
MyForm_Codes
MyForm_Show
PgmEnd:
If Err.Number <> 0 Then
MsgBox "Error No.:" & Err.Number & vbNewLine & _
"Description : " & Err.Description, , "Print Preview'"
End If
MyForm_Remove 'To Keep userform1 then comment this line
Application.Visible = 1
End Sub
Function MyForm_Create()
MyForm_Remove ' If Userform1 exist then remove it.
With ThisWorkbook.VBProject.VBComponents
Set myform = .Add(3).Designer ' Create & set form designer
End With
End Function
Function MyForm_Controls_Create()
Dim cmd1 As MSForms.Control
Dim lbox1 As MSForms.Control
With myform.Controls
Set lbox1 = .Add("Forms.listbox.1")
Set cmd1 = .Add("Forms.CommandButton.1")
End With
With cmd1
.Top = 80
.Left = 40
.Caption = "Preview"
.ControlTipText = "Click to Preview selected Sheets"
End With
With lbox1
.Top = 5
.Left = 15
.Width = 115
.ColumnCount = 1
.ControlTipText = "Click to Select/Unselect, Double Click to Activate Sheet"
End With
Set lbox1 = Nothing
Set cmd1 = Nothing
Set myform = Nothing
End Function
Function MyForm_Codes()
Dim MyCtlEvents As Integer
With ThisWorkbook.VBProject.VBComponents("Userform1").CodeModule
If bShow Then
MyCtlEvents = .CreateEventProc("Click", "CommandButton1")
.InsertLines MyCtlEvents + 1, "Print_Job"
MyCtlEvents = .CreateEventProc("DblClick", "Listbox1")
.InsertLines MyCtlEvents + 1, "Sht_Activate"
MyCtlEvents = .CreateEventProc("Click", "Userform")
.InsertLines MyCtlEvents + 1, "Msgbox ""By Shailesh Shah"",,""Print Preview"" "
MyCtlEvents = .CreateEventProc("Initialize", "Userform")
.InsertLines MyCtlEvents + 1, "Lbox1_Fill"
Else
.InsertLines 1, "Sub CommandButton1_Click()"
.InsertLines 2, "Print_Job"
.InsertLines 3, "End Sub"
.InsertLines 1, "Sub Listbox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)"
.InsertLines 2, "Sht_Activate"
.InsertLines 3, "End Sub"
.InsertLines 1, "Sub Userform_Click"
.InsertLines 2, "Msgbox ""Print Preview:- By Shailesh Shah"",,""About"""
.InsertLines 3, "End Sub"
.InsertLines 1, "Sub Userform_Initialize"
.InsertLines 2, "Lbox1_fill"
.InsertLines 3, "End Sub"
End If
End With
End Function
Function MyForm_Show()
With UserForm1
.Caption = "Print Preview"
.Height = 125
.Width = 150
.Show
End With
End Function
Function MyForm_Remove()
On Error Resume Next
With ThisWorkbook.VBProject
.VBComponents.Remove .VBComponents("Userform1")
End With
Err.Clear
End Function
Function LBox1_Fill()
Dim sht As Variant
With UserForm1.ListBox1
For Each sht In Sheets
On Error Resume Next
If sht.Visible And Application.CountA(sht.Cells) > 0 Then
.AddItem sht.Name
.MultiSelect = 1
If sht.Name = ActiveSheet.Name Then
.Selected(.ListCount - 1) = True
.ListIndex = .ListCount - 1
End If
End If
Err.Clear
Next sht
If .ListCount = 0 Then
UserForm1.CommandButton1.Visible = 0
.AddItem "No Sheets found to Preview."
Else
.TopIndex = .ListIndex
End If
End With
End Function
Function Print_Job()
Dim i As Integer
With UserForm1
.Hide
Application.Visible = 1
For i = 0 To .ListBox1.ListCount - 1
If .ListBox1.Selected(i) Then
Application.ScreenUpdating = 0
Sheets(.ListBox1.List(i)).PrintPreview
End If
Next i
Application.ScreenUpdating = bShow
Application.Visible = bShow
.Show
End With
End Function
Function Sht_Activate()
On Error Resume Next
With UserForm1.ListBox1
Sheets(.List(.ListIndex)).Activate
End With
Err.Clear
Unload UserForm1
MyForm_Remove 'To Keep userform1 then comment this line
Application.Visible = 1
End Function
Go Top

UDF for Sentence Case for cells:

Usage = "=wdsentcase(A1)"
Where A1 is the reference cell
Function WdSentCase(mytext As String)
Dim WdDocTemp As Object
Set WdDocTemp = CreateObject("word.document")
With WdDocTemp.Application.Selection
.Text = mytext
.Range.Case = 4
WdSentCase = .Range
.Parent.Parent.Close 0
End With
Set WdDocTemp = Nothing
End Function
To work this UDF MS word should also be installed.
to use with macro
Sub SentCase() 'Assign Shortcut key
Dim C As Range, rng As Range
If Selection.Count = 1 Then
Set rng = ActiveCell
Else
Set rng = Selection.SpecialCells(xlCellTypeConstants).Cells
End If
Application.Calculation = xlCalculationManual
Application.EnableEvents = 0
For Each C In rng
With C
.Formula = WdSentCase(.Formula)
End With
Next C
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = 1
End Sub
Go Top