Saturday, September 1, 2012

Create a Quick Custom Format Tab on Mouse Right Click

Create a new menu "Quick Custom Format Tab" on mouse right click for quickly applying the custom formatting on your workbook. Snapshot below -

All you have to do is download the workbook 
Keep adding the new custom formats which you use on daily basis on the worksheet "Custom_Formats" . 
Note Make sure text in column D is unique .
You can also move these worksheet to your own workbook and use them . Don't forget to move the VBA modules as well 

Udf's Used -

Function no_like(cl As Range)
no_like = "' " & cl.Text
End Function

Function know_cutsomformat(cl As Range)

know_cutsomformat = cl.NumberFormat
End Function

Workbook Module code- 
Private Sub Workbook_Open()
    On Error Resume Next
    Application.CommandBars("Cell").Controls("Quick Custom Format Tab").Delete
    Call add_custom_menu
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Application.CommandBars("Cell").Controls("Quick Custom Format Tab").Delete
End Sub

Paste below code in module 1 or any new module
Option Explicit
Sub add_custom_menu()
    Dim cBut        As CommandBarControl
    On Error Resume Next

    Application.CommandBars("Cell").Controls("Quick Custom Format Tab").Delete
    Set cBut = Application.CommandBars("Cell").Controls.Add(Type:=msoControlPopup, Temporary:=True)
    cBut.Caption = "Quick Custom Format Tab"
    cBut.OnAction = "new_button_macro"
End Sub

Sub new_button_macro()
Dim wk As Workbook
Dim wks As Worksheet
Dim cmda As CommandBarControl
Dim cbut2 As CommandBarControl, CBT3 As CommandBarControl
Dim i As Long, j As Long

    For Each cmda In Application.CommandBars("Cell").Controls("Quick Custom Format Tab").Controls
        On Error Resume Next
    For i = 2 To ThisWorkbook.Sheets("Custom_Formats").Range("a65356").End(xlUp).Row
        Set cbut2 = Application.CommandBars("Cell").Controls("Quick Custom Format Tab").Controls.Add(Type:=msoControlPopup)
        With cbut2
            .Caption = ThisWorkbook.Sheets("Custom_Formats").Range("a" & i).Value
            .BeginGroup = True
        End With
        For j = i To i - 1 + Application.WorksheetFunction.CountIf(ThisWorkbook.Sheets("Custom_Formats").Columns("a:a"), ThisWorkbook.Sheets("Custom_Formats").Range("a" & i).Value)
            Set CBT3 = cbut2.Controls.Add(Type:=msoControlButton)
            With CBT3
                .Caption = ThisWorkbook.Sheets("Custom_Formats").Range("d" & j).Value
                .OnAction = "format"
                .BeginGroup = False
                .FaceId = 351
            End With
       i = j - 1
End Sub

Sub format()
Dim i As Long

If Application.WorksheetFunction.CountIf(ThisWorkbook.Sheets("Custom_Formats").Columns("d:d"), Application.CommandBars.ActionControl.Caption) > 0 Then
    i = Application.WorksheetFunction.Match(Application.CommandBars.ActionControl.Caption, ThisWorkbook.Sheets("Custom_Formats").Columns("d:d"), 0)
    Selection.NumberFormat = ThisWorkbook.Sheets("Custom_Formats").Range("c" & i).Value
    MsgBox "Custom format not available"
End If

End Sub

Download working workbook here 

1 comment:

  1. Join Our Form/Group to Post and Solve MS Excel Problems!forum/excelvbamacros