Updating Excel Chart range via vba/macros

Option Explicit
 
Sub WeeklyChartUpdate()
Call UpdateChartFormula
Call SetPrintArea
MsgBox "Chart areas updated", vbOKOnly
End Sub
 
 
Sub UpdateChartFormula()
Dim chrt As Object
Dim i As Integer, k As Integer
Dim SeriesFormula() As String, ReturnFormula As String, R1C1Part As String
Const CurrentYear As String = "2008"
 
For Each chrt In ActiveSheet.ChartObjects
    Select Case True
        'checks chart names that have been defined using one off sub NameCharts()
        'will categorise charts as either "rolling" type or "yearly" type - they need
        'to be treated differently
        Case chrt.Name Like "*Rolling*"
            'change start and end points of all series
            For i = 1 To chrt.Chart.SeriesCollection.Count
                SeriesFormula = Split(chrt.Chart.SeriesCollection(i).FormulaR1C1, ",")
                For k = 0 To UBound(SeriesFormula)
                    Debug.Print SeriesFormula(k)
                    If k = 1 Or k = 2 Then
                        'AXIS or VALUE part of formula (these are fixed positions 1 & 2)
                        'we want to change both parts of the formula - the start and the end point
                        'the "rolling" charts are a 12 week rolling total summary so both points move
                        'find the first RC part of the formula (from the ! to the : part)
                        'add 1 to the C
                        R1C1Part = Mid(SeriesFormula(k), InStr(1, SeriesFormula(k), "!") + 1, (Len(SeriesFormula(k)) - InStr(1, SeriesFormula(k), ":")) - 1)
                        SeriesFormula(k) = Replace(SeriesFormula(k), R1C1Part, OffsetC1(R1C1Part))
                        'find the second RC part of the formula (from the : to the end)
                        'add 1 to the C
                        R1C1Part = Mid(SeriesFormula(k), InStr(1, SeriesFormula(k), ":") + 1)
                        SeriesFormula(k) = Replace(SeriesFormula(k), R1C1Part, OffsetC1(R1C1Part))
                    End If
                Next k
            'rebuild formula
            ReturnFormula = Join(SeriesFormula(), ",")
            chrt.Chart.SeriesCollection(i).FormulaR1C1 = ReturnFormula
            Next i
        Case chrt.Name Like "*Yearly*"
            'change current year series only - this will need to be changed on a yearly basis!!!
            For i = 1 To chrt.Chart.SeriesCollection.Count
                If chrt.Chart.SeriesCollection(i).Name Like "*" & CurrentYear & "*" Then
                    SeriesFormula = Split(chrt.Chart.SeriesCollection(i).FormulaR1C1, ",")
                    For k = 0 To UBound(SeriesFormula)
                        Debug.Print SeriesFormula(k)
                        If k = 2 Then
                            'VALUE part of formula only
                            'find ONLY the second RC part of the formula (from the : to the end)
                            'we don't want to change the starting point for the current year series, or the AXIS values-
                            'always want to see the year to date totals
                            R1C1Part = Mid(SeriesFormula(k), InStr(1, SeriesFormula(k), ":") + 1)
                            SeriesFormula(k) = Replace(SeriesFormula(k), R1C1Part, OffsetC1(R1C1Part))
                        End If
                    Next k
                    'rebuild formula
                    ReturnFormula = Join(SeriesFormula(), ",")
                    chrt.Chart.SeriesCollection(i).FormulaR1C1 = ReturnFormula
                
                End If
            Next i
        Case Else
            MsgBox "Unrecognised Chart name - if you have inserted a new chart you will need to rename it. Please contact IT (hs)", vbCritical, "SOME CHARTS WILL NOT UPDATE PROPERLY"
    End Select
 
Next chrt
End Sub
 
Sub SetPrintArea()
    Dim PA1 As String, PA2 As String, PA As String
    'Print areas
    Dim D1Pos As Integer, D2Pos As Integer, D3Pos As Integer, D4Pos As Integer
    'Position of $ in string - to calculate where the column headers are
    'takes current print area and moves it along 1
    D1Pos = InStr(1, ActiveSheet.PageSetup.PrintArea, "$")
    D2Pos = InStr(D1Pos + 1, ActiveSheet.PageSetup.PrintArea, "$")
    D3Pos = InStr(D2Pos + 1, ActiveSheet.PageSetup.PrintArea, "$")
    D4Pos = InStr(D3Pos + 1, ActiveSheet.PageSetup.PrintArea, "$")
    
    PA = ActiveSheet.PageSetup.PrintArea
    
    PA1 = Mid(ActiveSheet.PageSetup.PrintArea, D1Pos + 1, D2Pos - D1Pos - 1)
    PA2 = Mid(ActiveSheet.PageSetup.PrintArea, D3Pos + 1, D4Pos - D3Pos - 1)
    PA = Replace(PA, PA1, GetNextColumn(PA1))
    PA = Replace(PA, PA2, GetNextColumn(PA2))
    
    ActiveSheet.PageSetup.PrintArea = PA
End Sub
 
Function OffsetC1(ByVal R1C1In As String)
Dim OrigCNo As Integer, R1C1Out As String
 
OrigCNo = Mid(R1C1In, InStr(1, R1C1In, "C") + 1)
OffsetC1 = Replace(R1C1In, "C" & OrigCNo, "C" & OrigCNo + 1)
 
End Function
Function GetNextColumn(ByVal InChar As String) As String
 
Dim ExcelColumns As Variant
Dim i As Integer
Dim GotChar As Boolean
On Error GoTo GetNextColumn_Err
 
GotChar = False
    
InChar = UCase(InChar)
ExcelColumns = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", _
"AA", "AB", "AC", "AD", "AE", "AF", "AG", "AH", "AI", "AJ", "AK", "AL", "AM", "AN", "AO", "AP", "AQ", "AR", "AS", "AT", "AU", "AV", "AW", "AX", "AY", "AZ", _
"BA", "BB", "BC", "BD", "BE", "BF", "BG", "BH", "BI", "BJ", "BK", "BL", "BM", "BN", "BO", "BP", "BQ", "BR", "BS", "BT", "BU", "BV", "BW", "BX", "BY", "BZ", _
"CA", "CB", "CC", "CD", "CE", "CF", "CG", "CH", "CI", "CJ", "CK", "CL", "CM", "CN", "CO", "CP", "CQ", "CR", "CS", "CT", "CU", "CV", "CW", "CX", "CY", "CZ", _
"DA", "DB", "DC", "DD", "DE", "DF", "DG", "DH", "DI", "DJ", "DK", "DL", "DM", "DN", "DO", "DP", "DQ", "DR", "DS", "DT", "DU", "DV", "DW", "DX", "DY", "DZ", _
"EA", "EB", "EC", "ED", "EE", "EF", "EG", "EH", "EI", "EJ", "EK", "EL", "EM", "EN", "EO", "EP", "EQ", "ER", "ES", "ET", "EU", "EV", "EW", "EX", "EY", "EZ", _
"FA", "FB", "FC", "FD", "FE", "FF", "FG", "FH", "FI", "FJ", "FK", "FL", "FM", "FN", "FO", "FP", "FQ", "FR", "FS", "FT", "FU", "FV", "FW", "FX", "FY", "FZ", _
"GA", "GB", "GC", "GD", "GE", "GF", "GG", "GH", "GI", "GJ", "GK", "GL", "GM", "GN", "GO", "GP", "GQ", "GR", "GS", "GT", "GU", "GV", "GW", "GX", "GY", "GZ", _
"HA", "HB", "HC", "HD", "HE", "HF", "HG", "HH", "HI", "HJ", "HK", "HL", "HM", "HN", "HO", "HP", "HQ", "HR", "HS", "HT", "HU", "HV", "HW", "HX", "HY", "HZ", _
"IA", "IB", "IC", "ID", "IE", "IF", "IG", "IH", "II", "IJ", "IK", "IL", "IM", "IN", "IO", "IP", "IQ", "IR", "IS", "IT", "IU", "IV")
 
i = 0
    Do While GotChar = False
        If ExcelColumns(i) = InChar Then
            GotChar = True
        Else
            i = i + 1
        End If
    Loop
    GetNextColumn = ExcelColumns(i + 1)
'End If
 
GetNextColumn_Exit:
    Exit Function
 
GetNextColumn_Err:
    
    If Err.Number = 9 Then
        Select Case InChar
            Case Is = ""
                MsgBox "Valid character required"
                GetNextColumn = ""
            Case Is = "IV"
                MsgBox "This is the last available column header (IV)"
                GetNextColumn = "IV"
            Case Else
               MsgBox "Invalid Excel column header " & InChar
               GetNextColumn = ""
        End Select
        Resume GetNextColumn_Exit
    Else
        MsgBox Err.Description
        Resume GetNextColumn_Exit
    End If
End Function
                                  

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156: