Changing font of an existing spreadsheet with thousands of sheets

[Edjackson]

Hey everybody,

I've elaborated a spreadsheet with thousands of tabs. Now I got an e-mail to change the font of my graphics and tables. How can I do that now that everything is already done?

Thanks in advance

Edjackson

 

[SirJB7]

Hi, Edjackson!

When you wrote thousands do you actually mean thousands? Cofff... cofff...

Give a look at this file:
https://dl.dropboxusercontent.com/u...of sheets (for Edjackson at chandoo.org).xlsm

You'll have to to something like this:

Option Explicit

Sub WhyDoPeopleWantToGetInTrouble()
    ' constants
    Const ksIMessedItUp = "Arial"
    Const ksIShouldAskBefore = "Times New Roman"
    ' declarations
    Dim I As Integer, J As Integer, K As Integer
    Dim c As Range, cht As Chart
    ' start
    ' process
    For I = 1 To Worksheets.Count
        With Worksheets(I)
            ' cells
            '  this is the easy part
            For Each c In Worksheets(I).UsedRange
                With c
                    If .Font.Name = ksIMessedItUp Then
                        .Font.Name = ksIShouldAskBefore
                        ' note: this is only for the font name
                        ' but you have all these parameters to consider:
'                        With Selection.Font
'                            .Name = "Arial"
'                            .Size = 8
'                            .Strikethrough = False
'                            .Superscript = False
'                            .Subscript = False
'                            .OutlineFont = False
'                            .Shadow = False
'                            .Underline = xlUnderlineStyleNone
'                            .ThemeColor = xlThemeColorLight1
'                            .TintAndShade = 0
'                            .ThemeFont = xlThemeFontNone
'                        End With
                    End If
                End With
            Next c
            Set c = Nothing
            ' charts
            '  this is the hardest (and unexplored) part
            For J = 1 To ActiveSheet.ChartObjects.Count
                Set cht = ActiveSheet.ChartObjects(J).Chart
                With cht
                    ' title
                    If .HasTitle Then
                        With .ChartTitle.Font
                            If .Name = ksIMessedItUp Then
                                .Name = ksIShouldAskBefore
                            End If
                        End With
                    End If
                    ' axes
                    If .HasAxis(xlValue) Then
                        If .Axes(xlValue).HasTitle Then
                            With .Axes(xlValue).AxisTitle.Font
                                If .Name = ksIMessedItUp Then
                                    .Name = ksIShouldAskBefore
                                End If
                            End With
                        End If
GoTo A:
                        With .Axes(xlValue).Format.TextFrame2.TextRange.Font
                            If .Name = ksIMessedItUp Then
                                .Name = ksIShouldAskBefore
                            End If
                        End With
A:
                    End If
                    If .HasAxis(xlCategory) Then
                        If .Axes(xlCategory).HasTitle Then
                            With .Axes(xlCategory).AxisTitle.Font
                                If .Name = ksIMessedItUp Then
                                    .Name = ksIShouldAskBefore
                                End If
                            End With
                        End If
GoTo B:
                        With .Axes(xlCategory).Format.TextFrame2.TextRange.Font
                            If .Name = ksIMessedItUp Then
                                .Name = ksIShouldAskBefore
                            End If
                        End With
B:
                    End If
                    ' legend
                    If .HasLegend Then
                        With .Legend.Font
                            If .Name = ksIMessedItUp Then
                                .Name = ksIShouldAskBefore
                            End If
                        End With
                    End If
                    ' data series
                    For K = 1 To .SeriesCollection.Count
                        With .SeriesCollection(K).DataLabels.Format.TextFrame2.TextRange.Font
                            If .Name = ksIMessedItUp Then
                                .Name = ksIShouldAskBefore
                            End If
                        End With
                    Next K
                End With
                Set cht = Nothing
            Next J
        End With
    Next I
    ' end
    Beep
End Sub

This is something I've never done before so there are 2 parts for which I can't find out the proper qualification, so it'd remain as you homework if that is required. Good luck!

Regards!

PS: BTW, don't do that again, with hundreds should be enough...