[x]
Posted via EE Mobile

Search, ask, and monitor your questions on the go with EE Mobile. Visit Experts Exchange from your mobile device and never be out of touch again.
Question
[x]
Attachment Details
[x]
The Solution Rating System

With so many solutions, how can you tell which solutions are most likely to help you and which ones are not? To provide you with a tool to use, we rate our solutions based on various elements that most accurately determine if a solution is a quality solution. To explain what factors affect the solution rating, here are the elements we take into consideration when formulating our solution rating.

  • The Grade of the Solution
  • The Zone Rank of the Expert Providing the Solution
  • The Number of Author and Expert Comments
  • The Number of Experts Contributing
  • The Feedback of the Community

Your Input Matters
Because of the way the system is set up, the most important variable in this equation is you. As a member of Experts Exchange, you are able to cast your vote on the quality of the solutions in regard to how complete, accurate, helpful and easy to understand each solution is. When you provide your feedback, each rating is adjusted accordingly. So, if you see a solution that has a poor rating that you think is a good solution, let us know by rating it. As you do, the rating will be adjusted and will become more accurate for other members of our site.

If you have any suggestions that you would like to make for our rating system, please ask a question in the Suggestions Zone of Community Support.

Thank you!
9.3

Updating Excel Chart range via vba/macros

Asked by bhups11 in Automation, Microsoft Excel Spreadsheet Software

Tags: Microsoft, excel, 2003

Hi there,

I am currently running a code which automatically updates 30 or sharts at once by adding 1 column to the beginning and end of the series. For example Chart 1 refers to columns A to E, after running the macro the Range will change to B to F.
Currently, all the charts have 3 series, if i try to add a 4th series to the chart and macro it does not work.

How can I amend the code so that it updates 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.

Your help would be kindly appreciated. 
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:

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
[+][-]09/08/08 06:23 AM, ID: 22416977Accepted Solution

View this solution now by starting your 30-day free trial. Setting up your free trial is quick, easy, and secure. We will return you to this solution, unlocked, when you're done.

About this solution

Zones: Automation, Microsoft Excel Spreadsheet Software
Tags: Microsoft, excel, 2003
Sign Up Now!
Solution Provided By: rorya
Participating Experts: 1
Solution Grade: A
 
[+][-]09/08/08 02:13 AM, ID: 22415613Expert Comment

At Experts Exchange, members can ask their questions to thousands of technology professionals, also known as Experts. Experts compete and collaborate to answer those questions by leaving comments like this one.

Start your 30-day free trial to view this Expert Comment or ask the Experts your question.

 
[+][-]09/08/08 05:44 AM, ID: 22416675Author Comment

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 30-day free trial to view this Author Comment or ask the Experts your question.

 
[+][-]09/08/08 07:27 AM, ID: 22417677Author Comment

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 30-day free trial to view this Author Comment or ask the Experts your question.

 
[+][-]09/08/08 07:55 AM, ID: 22417975Author Comment

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 30-day free trial to view this Author Comment or ask the Experts your question.

 
[+][-]09/08/08 08:03 AM, ID: 22418062Expert Comment

At Experts Exchange, members can ask their questions to thousands of technology professionals, also known as Experts. Experts compete and collaborate to answer those questions by leaving comments like this one.

Start your 30-day free trial to view this Expert Comment or ask the Experts your question.

 
 
Loading Advertisement...
20091111-EE-VQP-92 / EE_QW_2_20070628