Download Free Office (Classic) Menu - 2003 Addins for Office-2007 from
http://in.geocities.com/shahshaileshs/menuaddins
MENU
|
Formula to get sheet name in cell. Function GetShtName() With Application .Volatile (True) GetShtName = .Caller.Parent.Name End With End Function In any cell (e.g. A1) type below formula (Copy formula to other sheets) =GetShtName()
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
'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
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
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
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
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
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