Hi there,
I am currently <NOBR>running</NOBR> a code which automatically updates 30 or sharts at once by <NOBR>adding</NOBR> 1 column to the beginning and end of the <NOBR>series</NOBR>. For example Chart 1 refers to columns A to E, after running the <NOBR>macro</NOBR> the Range will change to B to F.
Currently, all the <NOBR>charts</NOBR> have 3 series, if i try to add a 4th series to the chart and macro it does not <NOBR>work</NOBR>.
How can I amend the code so that it <NOBR>updates</NOBR> all 4 series in all of the charts instead of updating just three series for all charts?
I have added the 4th series to each of the chart, that I would like to be updated along with the 3 other series that are being update everytime i run the macro.
I have copied the existing code below. Currently, when i try to run it i get the error on the line:OrigCNo = Mid(R1C1In, InStr(1, R1C1In, "C") + 1).
I am only a beginner at Excel VBA so your help would be kindly appreciated.
Kind regards,
Bob
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
</TD>
I am currently <NOBR>running</NOBR> a code which automatically updates 30 or sharts at once by <NOBR>adding</NOBR> 1 column to the beginning and end of the <NOBR>series</NOBR>. For example Chart 1 refers to columns A to E, after running the <NOBR>macro</NOBR> the Range will change to B to F.
Currently, all the <NOBR>charts</NOBR> have 3 series, if i try to add a 4th series to the chart and macro it does not <NOBR>work</NOBR>.
How can I amend the code so that it <NOBR>updates</NOBR> all 4 series in all of the charts instead of updating just three series for all charts?
I have added the 4th series to each of the chart, that I would like to be updated along with the 3 other series that are being update everytime i run the macro.
I have copied the existing code below. Currently, when i try to run it i get the error on the line:OrigCNo = Mid(R1C1In, InStr(1, R1C1In, "C") + 1).
I am only a beginner at Excel VBA so your help would be kindly appreciated.
Kind regards,
Bob
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
</TD>
