Hi there!
I am new to using macros and have recently inherited a multiple tabbed, multiple workbook, macro formatted beast and have stumbled upon a few issues. I was instructed to click "debug" when there was an issue with the macro and then simply drag the yellow arrow down one row so that the macro can continue to run, however I would like to fix the macro instead of pretend that an issue doesn't exhist. Can someone please help determine what this bug is and how to fix it? I have bolded the two lines that cause an error. These lines are entitled: "ActiveChart.SeriesCollection(1).Points(5).Select".
Thanks so much!
Sub Auto_PageNum()
'
' PageNum Macro
' Macro created on 10/27/09 by XXXXX
' Macro updated June 2012 by XXXXX
Dim wb As Workbook, ws As Worksheet
Dim strPgNo, strResponse
Dim x, y, z
strResponse = MsgBox("Are you sure you want to run the auto page number routine?", vbYesNo + vbCritical + vbDefaultButton2, "Page No?")
z = 1
If strResponse = vbYes Then
updateStatus ("PageNo")
application.ScreenUpdating = False
For Each wb In Workbooks
Select Case wb.Name
Case "QA Package - Part 1.xlsx", "QA Package - Part 2.xlsx", "QA Package - Part 3.xlsx", "QA Package - Part 4 - NonGAAP.xlsx", "QA Package - App C.xlsx"
For Each ws In wb.Worksheets
For x = 2 To 124
If ws.Name = Workbooks("QA Package - Main.xlsm").Sheets("Pages").Cells(x, 10).Value Then
strPgNo = Workbooks("QA Package - Main.xlsm").Sheets("Pages").Cells(x, 12).Value
If strPgNo <> 0 And strPgNo <> "F" Then
ws.PageSetup.CenterFooter = "&""Arial,Regular""&9 " & strPgNo
End If
Exit For
End If
Next x
Next
End Select
z = z + 1
Next
application.ScreenUpdating = True
updateStatus ("Finished")
End If
End Sub
Sub Format_Charts()
'AutoScaleCharts Macro
'Macro created 10/13/2009 by XXXXX
'Macro updated June 2012 by XXXXX
Dim wb As Workbook, ws As Worksheet, co As ChartObject, ch As Chart
Dim tmpMin, tmpMax, tmpMaj
Dim arrColor, arrFonts
Dim strPkg
Dim ChType, ChNum, ChScale, ChColor, ChSeries
Dim x, y, p
Dim Color_Blue As Long
Dim Color_Yellow As Long
Dim Color_Red As Long
Dim Color_Silver As Long
Dim Color_White As Long
Dim Color_Green As Long
Color_Blue = 41
ActiveWorkbook.Colors(Color_Blue) = RGB(48, 76, 178)
Color_Yellow = 44
ActiveWorkbook.Colors(Color_Yellow) = RGB(255, 191, 39)
Color_Red = 3
ActiveWorkbook.Colors(Color_Red) = RGB(213, 21, 46)
Color_Silver = 15
ActiveWorkbook.Colors(Color_Silver) = RGB(94, 126, 149)
Color_White = 34
ActiveWorkbook.Colors(Color_White) = RGB(229, 227, 227)
Color_Green = 4
ActiveWorkbook.Colors(Color_Green) = RGB(0, 133, 34)
strPackage = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range("B42").Value
strPkg = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range("F4").Value '1 = Quarterly Analysis 2 = Budget/AOP
arrColor = Array("K12", "K4", "K16")
arrFont = Array("L12", "L4", "L16")
y = 1
'updateStatus ("Graphs")
'application.ScreenUpdating = False
For Each wb In Workbooks
Select Case wb.Name
Case "QA Package - Part 4 - NonGAAP.xlsx", "QA Package - Part 1.xlsx", "QA Package - Part 2.xlsx", "QA Package - Part 3.xlsx", "QA Package - App C.xlsx"
' If p = 18 Then GoTo tempx ' will stop the retrieval after part 3, and not retrieve App A, B, & C
For Each ws In wb.Worksheets
For Each co In ws.ChartObjects
co.Activate
ChType = Mid(co.Name, 1, 5)
ChNum = Mid(co.Name, 6, 1)
ChScale = Mid(co.Name, 7, 1)
ChColor = Mid(co.Name, 8, 1)
ChSeries = Mid(co.Name, 9, 1)
Debug.Print ChType, ChNum, ChScale, ChColor, ChSeries
'Checks to see if chart should auto scale. If ChScale is set to 0 it will not auto-scale
If ChScale = 1 Then
For Each ax In ActiveChart.Axes
If ax.Type = xlValue Then
ax.Select
With ax
.MinimumScaleIsAuto = True
.MaximumScaleIsAuto = True
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
.Crosses = xlAutomatic
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
End With
'Calculates the minimum and maximum values then divides so there are 5 grid lines in the chart
tmpMax = ax.MaximumScale
tmpMin = ax.MinimumScale
tmpMaj = (tmpMax - tmpMin) / 5
ax.Select
With ax
.MinimumScale = tmpMin
.MaximumScale = tmpMax
.MinorUnitIsAuto = True
.MajorUnit = tmpMaj
.Crosses = xlAutomatic
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
End With
End If
Next
End If
'Checks chart type, color, and series and formats accordingly
If ChColor = 1 Then
Select Case ChType
Case "SmBar", "LgBar"
ActiveChart.SeriesCollection(1).Select
With selection.Interior
.ColorIndex = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range(arrColor(0)).Value
.Pattern = xlSolid
End With
ActiveChart.SeriesCollection(1).Points(5).Select
With selection.Interior
.ColorIndex = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range(arrColor(1)).Value
.Pattern = xlSolid
End With
Case "SmStk", "LgStk", "MxStk", "SmSBr", "LgSBr"
For x = 1 To ChSeries
ActiveChart.SeriesCollection(x).Select
With selection.Interior
.ColorIndex = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range(arrColor(x - 1)).Value
.Pattern = xlSolid
End With
If ChType = "SmStk" Or ChType = "LgStk" Or ChType = "MxStk" Then
On Error Resume Next
Err.Clear
ActiveChart.SeriesCollection(x).DataLabels.Select
If Err.Number <> 1004 Then
With selection.Font
If ActiveSheet.Name = "Yields" And co.Name = "SmStk5112" Then
Else
.ColorIndex = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range(arrFont(x - 1)).Value
End If
.Background = xlTransparent
End With
End If
Resume
End If
Next x
Case Else
End Select
End If
Next
range("A1").Select
Next
End Select
y = y + 1
Next
'tempx:
Update_ColWidths
'Update_AppA401k
application.ScreenUpdating = True
updateStatus ("Finished")
End Sub
Sub Update_ColWidths()
'
' Macro created on 10/28/2009 by XXXXX
'Macro updated June 2012 by XXXXX
Dim wb As Workbook, ws As Worksheet
Dim strWrkBk As String, strWrkSht As String
Dim strUpdateCols, strPkg, strPrd, x, y, z
z = 1
updateStatus ("Columns")
application.ScreenUpdating = False
strPrd = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range("B4").Value
For Each wb In Workbooks
Select Case wb.Name
Case "QA Package - Part 1.xlsx", "QA Package - Part 2.xlsx", "QA Package - Part 3.xlsx", "QA Package - Part 4 - NonGAAP.xlsx", "QA Package - App C.xlsx"
For Each ws In wb.Worksheets
For x = 2 To 134
If ws.Name = Workbooks("QA Package - Main.xlsm").Sheets("Pages").Cells(x, 10).Value Then
strUpdateCols = Workbooks("QA Package - Main.xlsm").Sheets("Pages").Cells(x, 19).Value
If strUpdateCols = "x" Then
wb.Activate
ws.Select
If strPrd = 7 Then
Columns("A:A").ColumnWidth = 64.43
Columns("B:B").ColumnWidth = 13
Columns("C:C").EntireColumn.Hidden = True
Columns("D:D").EntireColumn.Hidden = True
Columns("E:E").EntireColumn.Hidden = True
Columns("F:F").EntireColumn.Hidden = True
Columns("G:G").ColumnWidth = 13
Columns("H:H").ColumnWidth = 6.29
Else
Columns("A:A").ColumnWidth = 43.71
Columns("B:B").ColumnWidth = 13
Columns("C:C").EntireColumn.Hidden = True
Columns("D:D").ColumnWidth = 13
Columns("E:E").ColumnWidth = 6.29
Columns("F:F").EntireColumn.Hidden = True
Columns("G:G").ColumnWidth = 13
Columns("H:H").ColumnWidth = 6.29
End If
End If
Exit For
End If
Next x
Next
End Select
z = z + 1
Next
application.ScreenUpdating = True
updateStatus ("Finished")
End Sub
Sub Update_AppA401k()
Dim strMyVal
Dim x, y
strMyVal = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range("H42").Value
For x = 1 To 2
Workbooks("Appendix A - Dept Operating Expenses.xlsm").Activate
Sheets("AppA" & x).Select
If strMyVal = 1 Then
Rows("8:8").Select
selection.EntireRow.Hidden = False
'Buffer
Rows("60:60").Select
selection.EntireRow.Hidden = True
Else
Rows("8:8").Select
selection.EntireRow.Hidden = True
'Buffer
Rows("60:60").Select
selection.EntireRow.Hidden = False
End If
range("A1").Select
Next x
Workbooks("QA Package - Main.xlsm").Activate
Sheets("Main").Select
End Sub
Sub Format_Charts_CurPg()
'
' AutoScaleCharts Macro
' Macro created 10/13/2009 by XXXXX
'Macro updated June 2012 by XXXXX
Dim wb As Workbook, ws As Worksheet, co As ChartObject, ch As Chart
Dim tmpMin, tmpMax, tmpMaj
Dim arrColor, arrFonts
Dim SrsFont1, SrsFont2, SrsFont3
Dim ChType, ChNum, ChScale, ChColor, ChSeries
Dim x
Dim Color_Blue As Long
Dim Color_Yellow As Long
Dim Color_Red As Long
Dim Color_Silver As Long
Dim Color_White As Long
Dim Color_Green As Long
Color_Blue = 41
ActiveWorkbook.Colors(Color_Blue) = RGB(48, 76, 178)
Color_Yellow = 44
ActiveWorkbook.Colors(Color_Yellow) = RGB(255, 191, 39)
Color_Red = 3
ActiveWorkbook.Colors(Color_Red) = RGB(213, 21, 46)
Color_Silver = 15
ActiveWorkbook.Colors(Color_Silver) = RGB(94, 126, 149)
Color_White = 34
ActiveWorkbook.Colors(Color_White) = RGB(229, 227, 227)
Color_Green = 4
ActiveWorkbook.Colors(Color_Green) = RGB(0, 133, 34)
arrColor = Array("K12", "K4", "K16")
arrFont = Array("L12", "L4", "L16")
For Each co In ActiveSheet.ChartObjects
co.Activate
ChType = Mid(co.Name, 1, 5)
ChNum = Mid(co.Name, 6, 1)
ChScale = Mid(co.Name, 7, 1)
ChColor = Mid(co.Name, 8, 1)
ChSeries = Mid(co.Name, 9, 1)
'Debug.Print ChType, ChNum, ChScale, ChColor, ChSeries
'Checks to see if chart should auto scale. If ChScale is set to 0 it will not auto-scale
If ChScale = 1 Then
ActiveChart.Axes(xlValue).Select
With ActiveChart.Axes(xlValue)
.MinimumScaleIsAuto = True
.MaximumScaleIsAuto = True
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
.Crosses = xlAutomatic
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
End With
'Calculates the minimum and maximum values then divides so there are 5 grid lines in the chart
tmpMax = co.Chart.Axes(xlValue).MaximumScale
tmpMin = co.Chart.Axes(xlValue).MinimumScale
tmpMaj = (tmpMax - tmpMin) / 5
ActiveChart.Axes(xlValue).Select
With ActiveChart.Axes(xlValue)
.MinimumScale = tmpMin
.MaximumScale = tmpMax
.MinorUnitIsAuto = True
.MajorUnit = tmpMaj
.Crosses = xlAutomatic
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
End With
End If
'Checks chart type, color, and series and formats accordingly
If ChColor = 1 Then
Select Case ChType
Case "SmBar", "LgBar"
ActiveChart.SeriesCollection(1).Select
With selection.Interior
.ColorIndex = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range(arrColor(0)).Value
.Pattern = xlSolid
End With
ActiveChart.SeriesCollection(1).Points(5).Select
With selection.Interior
.ColorIndex = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range(arrColor(1)).Value
.Pattern = xlSolid
End With
Case "SmStk", "LgStk", "MxStk", "SmSBr", "LgSBr"
For x = 1 To ChSeries
ActiveChart.SeriesCollection(x).Select
With selection.Interior
.ColorIndex = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range(arrColor(x - 1)).Value
.Pattern = xlSolid
End With
If ChType = "SmStk" Or ChType = "LgStk" Or ChType = "MxStk" Then
On Error Resume Next
Err.Clear
ActiveChart.SeriesCollection(x).DataLabels.Select
If Err.Number <> 1004 Then
With selection.Font
If ActiveSheet.Name = "Yields" And co.Name = "SmStk5112" Then
Else
.ColorIndex = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range(arrFont(x - 1)).Value
End If
.Background = xlTransparent
End With
End If
Resume
End If
Next x
Case Else
End Select
End If
Next
range("A1").Select
End Sub
I am new to using macros and have recently inherited a multiple tabbed, multiple workbook, macro formatted beast and have stumbled upon a few issues. I was instructed to click "debug" when there was an issue with the macro and then simply drag the yellow arrow down one row so that the macro can continue to run, however I would like to fix the macro instead of pretend that an issue doesn't exhist. Can someone please help determine what this bug is and how to fix it? I have bolded the two lines that cause an error. These lines are entitled: "ActiveChart.SeriesCollection(1).Points(5).Select".
Thanks so much!
Sub Auto_PageNum()
'
' PageNum Macro
' Macro created on 10/27/09 by XXXXX
' Macro updated June 2012 by XXXXX
Dim wb As Workbook, ws As Worksheet
Dim strPgNo, strResponse
Dim x, y, z
strResponse = MsgBox("Are you sure you want to run the auto page number routine?", vbYesNo + vbCritical + vbDefaultButton2, "Page No?")
z = 1
If strResponse = vbYes Then
updateStatus ("PageNo")
application.ScreenUpdating = False
For Each wb In Workbooks
Select Case wb.Name
Case "QA Package - Part 1.xlsx", "QA Package - Part 2.xlsx", "QA Package - Part 3.xlsx", "QA Package - Part 4 - NonGAAP.xlsx", "QA Package - App C.xlsx"
For Each ws In wb.Worksheets
For x = 2 To 124
If ws.Name = Workbooks("QA Package - Main.xlsm").Sheets("Pages").Cells(x, 10).Value Then
strPgNo = Workbooks("QA Package - Main.xlsm").Sheets("Pages").Cells(x, 12).Value
If strPgNo <> 0 And strPgNo <> "F" Then
ws.PageSetup.CenterFooter = "&""Arial,Regular""&9 " & strPgNo
End If
Exit For
End If
Next x
Next
End Select
z = z + 1
Next
application.ScreenUpdating = True
updateStatus ("Finished")
End If
End Sub
Sub Format_Charts()
'AutoScaleCharts Macro
'Macro created 10/13/2009 by XXXXX
'Macro updated June 2012 by XXXXX
Dim wb As Workbook, ws As Worksheet, co As ChartObject, ch As Chart
Dim tmpMin, tmpMax, tmpMaj
Dim arrColor, arrFonts
Dim strPkg
Dim ChType, ChNum, ChScale, ChColor, ChSeries
Dim x, y, p
Dim Color_Blue As Long
Dim Color_Yellow As Long
Dim Color_Red As Long
Dim Color_Silver As Long
Dim Color_White As Long
Dim Color_Green As Long
Color_Blue = 41
ActiveWorkbook.Colors(Color_Blue) = RGB(48, 76, 178)
Color_Yellow = 44
ActiveWorkbook.Colors(Color_Yellow) = RGB(255, 191, 39)
Color_Red = 3
ActiveWorkbook.Colors(Color_Red) = RGB(213, 21, 46)
Color_Silver = 15
ActiveWorkbook.Colors(Color_Silver) = RGB(94, 126, 149)
Color_White = 34
ActiveWorkbook.Colors(Color_White) = RGB(229, 227, 227)
Color_Green = 4
ActiveWorkbook.Colors(Color_Green) = RGB(0, 133, 34)
strPackage = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range("B42").Value
strPkg = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range("F4").Value '1 = Quarterly Analysis 2 = Budget/AOP
arrColor = Array("K12", "K4", "K16")
arrFont = Array("L12", "L4", "L16")
y = 1
'updateStatus ("Graphs")
'application.ScreenUpdating = False
For Each wb In Workbooks
Select Case wb.Name
Case "QA Package - Part 4 - NonGAAP.xlsx", "QA Package - Part 1.xlsx", "QA Package - Part 2.xlsx", "QA Package - Part 3.xlsx", "QA Package - App C.xlsx"
' If p = 18 Then GoTo tempx ' will stop the retrieval after part 3, and not retrieve App A, B, & C
For Each ws In wb.Worksheets
For Each co In ws.ChartObjects
co.Activate
ChType = Mid(co.Name, 1, 5)
ChNum = Mid(co.Name, 6, 1)
ChScale = Mid(co.Name, 7, 1)
ChColor = Mid(co.Name, 8, 1)
ChSeries = Mid(co.Name, 9, 1)
Debug.Print ChType, ChNum, ChScale, ChColor, ChSeries
'Checks to see if chart should auto scale. If ChScale is set to 0 it will not auto-scale
If ChScale = 1 Then
For Each ax In ActiveChart.Axes
If ax.Type = xlValue Then
ax.Select
With ax
.MinimumScaleIsAuto = True
.MaximumScaleIsAuto = True
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
.Crosses = xlAutomatic
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
End With
'Calculates the minimum and maximum values then divides so there are 5 grid lines in the chart
tmpMax = ax.MaximumScale
tmpMin = ax.MinimumScale
tmpMaj = (tmpMax - tmpMin) / 5
ax.Select
With ax
.MinimumScale = tmpMin
.MaximumScale = tmpMax
.MinorUnitIsAuto = True
.MajorUnit = tmpMaj
.Crosses = xlAutomatic
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
End With
End If
Next
End If
'Checks chart type, color, and series and formats accordingly
If ChColor = 1 Then
Select Case ChType
Case "SmBar", "LgBar"
ActiveChart.SeriesCollection(1).Select
With selection.Interior
.ColorIndex = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range(arrColor(0)).Value
.Pattern = xlSolid
End With
ActiveChart.SeriesCollection(1).Points(5).Select
With selection.Interior
.ColorIndex = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range(arrColor(1)).Value
.Pattern = xlSolid
End With
Case "SmStk", "LgStk", "MxStk", "SmSBr", "LgSBr"
For x = 1 To ChSeries
ActiveChart.SeriesCollection(x).Select
With selection.Interior
.ColorIndex = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range(arrColor(x - 1)).Value
.Pattern = xlSolid
End With
If ChType = "SmStk" Or ChType = "LgStk" Or ChType = "MxStk" Then
On Error Resume Next
Err.Clear
ActiveChart.SeriesCollection(x).DataLabels.Select
If Err.Number <> 1004 Then
With selection.Font
If ActiveSheet.Name = "Yields" And co.Name = "SmStk5112" Then
Else
.ColorIndex = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range(arrFont(x - 1)).Value
End If
.Background = xlTransparent
End With
End If
Resume
End If
Next x
Case Else
End Select
End If
Next
range("A1").Select
Next
End Select
y = y + 1
Next
'tempx:
Update_ColWidths
'Update_AppA401k
application.ScreenUpdating = True
updateStatus ("Finished")
End Sub
Sub Update_ColWidths()
'
' Macro created on 10/28/2009 by XXXXX
'Macro updated June 2012 by XXXXX
Dim wb As Workbook, ws As Worksheet
Dim strWrkBk As String, strWrkSht As String
Dim strUpdateCols, strPkg, strPrd, x, y, z
z = 1
updateStatus ("Columns")
application.ScreenUpdating = False
strPrd = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range("B4").Value
For Each wb In Workbooks
Select Case wb.Name
Case "QA Package - Part 1.xlsx", "QA Package - Part 2.xlsx", "QA Package - Part 3.xlsx", "QA Package - Part 4 - NonGAAP.xlsx", "QA Package - App C.xlsx"
For Each ws In wb.Worksheets
For x = 2 To 134
If ws.Name = Workbooks("QA Package - Main.xlsm").Sheets("Pages").Cells(x, 10).Value Then
strUpdateCols = Workbooks("QA Package - Main.xlsm").Sheets("Pages").Cells(x, 19).Value
If strUpdateCols = "x" Then
wb.Activate
ws.Select
If strPrd = 7 Then
Columns("A:A").ColumnWidth = 64.43
Columns("B:B").ColumnWidth = 13
Columns("C:C").EntireColumn.Hidden = True
Columns("D:D").EntireColumn.Hidden = True
Columns("E:E").EntireColumn.Hidden = True
Columns("F:F").EntireColumn.Hidden = True
Columns("G:G").ColumnWidth = 13
Columns("H:H").ColumnWidth = 6.29
Else
Columns("A:A").ColumnWidth = 43.71
Columns("B:B").ColumnWidth = 13
Columns("C:C").EntireColumn.Hidden = True
Columns("D:D").ColumnWidth = 13
Columns("E:E").ColumnWidth = 6.29
Columns("F:F").EntireColumn.Hidden = True
Columns("G:G").ColumnWidth = 13
Columns("H:H").ColumnWidth = 6.29
End If
End If
Exit For
End If
Next x
Next
End Select
z = z + 1
Next
application.ScreenUpdating = True
updateStatus ("Finished")
End Sub
Sub Update_AppA401k()
Dim strMyVal
Dim x, y
strMyVal = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range("H42").Value
For x = 1 To 2
Workbooks("Appendix A - Dept Operating Expenses.xlsm").Activate
Sheets("AppA" & x).Select
If strMyVal = 1 Then
Rows("8:8").Select
selection.EntireRow.Hidden = False
'Buffer
Rows("60:60").Select
selection.EntireRow.Hidden = True
Else
Rows("8:8").Select
selection.EntireRow.Hidden = True
'Buffer
Rows("60:60").Select
selection.EntireRow.Hidden = False
End If
range("A1").Select
Next x
Workbooks("QA Package - Main.xlsm").Activate
Sheets("Main").Select
End Sub
Sub Format_Charts_CurPg()
'
' AutoScaleCharts Macro
' Macro created 10/13/2009 by XXXXX
'Macro updated June 2012 by XXXXX
Dim wb As Workbook, ws As Worksheet, co As ChartObject, ch As Chart
Dim tmpMin, tmpMax, tmpMaj
Dim arrColor, arrFonts
Dim SrsFont1, SrsFont2, SrsFont3
Dim ChType, ChNum, ChScale, ChColor, ChSeries
Dim x
Dim Color_Blue As Long
Dim Color_Yellow As Long
Dim Color_Red As Long
Dim Color_Silver As Long
Dim Color_White As Long
Dim Color_Green As Long
Color_Blue = 41
ActiveWorkbook.Colors(Color_Blue) = RGB(48, 76, 178)
Color_Yellow = 44
ActiveWorkbook.Colors(Color_Yellow) = RGB(255, 191, 39)
Color_Red = 3
ActiveWorkbook.Colors(Color_Red) = RGB(213, 21, 46)
Color_Silver = 15
ActiveWorkbook.Colors(Color_Silver) = RGB(94, 126, 149)
Color_White = 34
ActiveWorkbook.Colors(Color_White) = RGB(229, 227, 227)
Color_Green = 4
ActiveWorkbook.Colors(Color_Green) = RGB(0, 133, 34)
arrColor = Array("K12", "K4", "K16")
arrFont = Array("L12", "L4", "L16")
For Each co In ActiveSheet.ChartObjects
co.Activate
ChType = Mid(co.Name, 1, 5)
ChNum = Mid(co.Name, 6, 1)
ChScale = Mid(co.Name, 7, 1)
ChColor = Mid(co.Name, 8, 1)
ChSeries = Mid(co.Name, 9, 1)
'Debug.Print ChType, ChNum, ChScale, ChColor, ChSeries
'Checks to see if chart should auto scale. If ChScale is set to 0 it will not auto-scale
If ChScale = 1 Then
ActiveChart.Axes(xlValue).Select
With ActiveChart.Axes(xlValue)
.MinimumScaleIsAuto = True
.MaximumScaleIsAuto = True
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
.Crosses = xlAutomatic
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
End With
'Calculates the minimum and maximum values then divides so there are 5 grid lines in the chart
tmpMax = co.Chart.Axes(xlValue).MaximumScale
tmpMin = co.Chart.Axes(xlValue).MinimumScale
tmpMaj = (tmpMax - tmpMin) / 5
ActiveChart.Axes(xlValue).Select
With ActiveChart.Axes(xlValue)
.MinimumScale = tmpMin
.MaximumScale = tmpMax
.MinorUnitIsAuto = True
.MajorUnit = tmpMaj
.Crosses = xlAutomatic
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
End With
End If
'Checks chart type, color, and series and formats accordingly
If ChColor = 1 Then
Select Case ChType
Case "SmBar", "LgBar"
ActiveChart.SeriesCollection(1).Select
With selection.Interior
.ColorIndex = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range(arrColor(0)).Value
.Pattern = xlSolid
End With
ActiveChart.SeriesCollection(1).Points(5).Select
With selection.Interior
.ColorIndex = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range(arrColor(1)).Value
.Pattern = xlSolid
End With
Case "SmStk", "LgStk", "MxStk", "SmSBr", "LgSBr"
For x = 1 To ChSeries
ActiveChart.SeriesCollection(x).Select
With selection.Interior
.ColorIndex = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range(arrColor(x - 1)).Value
.Pattern = xlSolid
End With
If ChType = "SmStk" Or ChType = "LgStk" Or ChType = "MxStk" Then
On Error Resume Next
Err.Clear
ActiveChart.SeriesCollection(x).DataLabels.Select
If Err.Number <> 1004 Then
With selection.Font
If ActiveSheet.Name = "Yields" And co.Name = "SmStk5112" Then
Else
.ColorIndex = Workbooks("QA Package - Main.xlsm").Sheets("Lookups").range(arrFont(x - 1)).Value
End If
.Background = xlTransparent
End With
End If
Resume
End If
Next x
Case Else
End Select
End If
Next
range("A1").Select
End Sub
Last edited: