Cell Macros: how to run macro from cells...

[itr674]

I have a file where I have six buttons at the top that execute Font, RowAutofit and Zoom macros.

These buttons are on 12 sheets so that makes 108 buttons.

There are about 50 sheets in the file but only 12 get the buttons.

I was thinking it might be easier to maintain if I ran the macros from cells on these sheets.

Any thoughts?

 

[erik.van.geit]

Hi,

like running "Macro1" by doubleclicking in a cell ?

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Macro1
End Sub

kind regards,
Erik

EDIT:
a better example might be

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Select Case Target.Address(0, 0)
    Case "A1": macro1
    Case "C1": macro2
    Case "E1": macro3
    Case "G1": macro4
    Case Else
    Exit Sub
    End Select
Cancel = True
End Sub

 

[itr674]

erik.van.geit--that would probably work, I'm taking since it is Private the code would have to be on each sheet?

 

[itr674]

erik.van.geit--oh yea that might be good, I'll start playing with some macros and get back with you--thanks a bunch...

 

[erik.van.geit]

yes, but that would involve too much code ...
my examples were meant to give it a try

you could put it in the workbookmodule this way

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
If Sh.Index > 12 Then Exit Sub
    Select Case Target.Address(0, 0)
    Case "A1": macro1
    Case "C1": macro2
    Case "E1": macro3
    Case "G1": macro4
    Case Else
    Exit Sub
    End Select
Cancel = True
End Sub

change the If ... Exit to your suits

kind regards,
Erik

 

[erik.van.geit]

or

Dim SheetsArray As Variant
SheetsArray = Array("WhatSheet", "SheetX", "ThisOne", "Another")
If IsError(Application.Match(Sh.Name, SheetsArray, 0)) Then Exit Sub

 

[itr674]

This works pretty good.

But I'm wondering if I could run the "SetFontAerial7_RowAutoFit" anytime the sheets are selected? This is a large file where I use a Main Menu and navigate to each sheet via hyperlinked cell.

The 12 sheets in question are schedule sheets with small text boxes that show what folks are doing throughout the day. For some reason the rows crop up in height so I continually reset the font and autofit the rows to get everything in order...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Select Case Target.Address(0, 0)
    Case "L1:W1": SetFontAeral7_RowAutoFit  'merger cell range L1:W1
    Case "Z1:AA1": Zoom75    'merger cell range L1:AA1
    Case "AB1:AC1": Zoom100  'merger cell range AB1:AC1
    Case "AD1:AE1": Zoom125  'merger cell range AD1:AE1
    Case "AF1:AG1": Zoom150  'merger cell range AF1:AG1
    Case Else
    Exit Sub
    End Select
Cancel = True
End Sub

Sub SetFontAeral7_RowAutoFit()
    ActiveSheet.Unprotect
    Application.ScreenUpdating = False
    Range(Selection, Selection.End(xlDown)).Select
    Rows("3:248").Select
    Range(Selection, Selection.End(xlDown)).Select
    With Selection.Font
        .Name = "Arial"
        .Size = 7
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
    End With
    Selection.Rows.AutoFit
    Range("I1").Select
    ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False
    Application.ScreenUpdating = True
End Sub

 

[erik.van.geit]

But I'm wondering if I could run the "SetFontAerial7_RowAutoFit" anytime the sheets are selected?

this way should work

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
SetFontAeral7_RowAutoFit
End Sub

 

[itr674]

Got it with

Private Sub Worksheet_Activate()
SetFontAeral7_RowAutoFit
End Sub

 

[erik.van.geit]

Got it with

Private Sub Worksheet_Activate()
SetFontAeral7_RowAutoFit
End Sub

yes, but this way you will need to repeat the code in each sheetmodule
with the workbookcode you can specify a sheetlist (see code with "SheetsArray")

Private Sub Workbook_SheetActivate(ByVal Sh As Object) 
Dim SheetsArray As Variant 
SheetsArray = Array("WhatSheet", "SheetX", "ThisOne", "Another") 
If IsError(Application.Match(Sh.Name, SheetsArray, 0)) Then Exit Sub
SetFontAeral7_RowAutoFit 
End Sub

(not tested but will be close)