I am trying to make a code for changing colour of one series to match another series but with different linestyle (eg. dashed). Please see the code that I have made. I get error messages.
Thank you
Sub lineeditor()
Dim j As Integer
Dim wsheet As Worksheet
Dim cht As ChartObject
Dim serie As Series
For Each wsheet In ThisWorkbook.Worksheets
'Looping through chart in every chartobjects
For Each cht In wsheet.ChartObjects
cht.Activate
cht.Select
'Looping through second set of 9 series. totally 18 series are in the chart
For j = 1 To 9
cht.Chart.SeriesCollection(j + 9).Select
With Selection.Format.Line
.ForeColor = cht.Chart.SeriesCollection(j).Format.Line.ForeColor
.DashStyle = msoLineDashDot
End With
Next
Next
Next
End Sub
You cannot select a worksheet object that is not on the ActiveSheet. You should, however, only select or activate objects when absolutely necessary. Watch: Excel VBA Introduction Part 5 - Selecting Cells (Range, Cells, Activecell, End, Offset).
Sub lineeditor()
Dim j As Integer
Dim wsheet As Worksheet
Dim cht As ChartObject
Dim serie As Series
For Each wsheet In ThisWorkbook.Worksheets
For Each cht In wsheet.ChartObjects
For j = 1 To 9
With cht.Chart.SeriesCollection(j + 9).Format.Line
.ForeColor = cht.Chart.SeriesCollection(j).Format.Line.ForeColor
.DashStyle = msoLineDashDot
End With
Next
Next
Next
End Sub
Related
I'd like to create a macro that counts the number of charts within a given range, then performs certain actions depending on the number counted. I know activesheet.chartobjects.count would count across the whole sheet, how would I modify to count within a range?
Here's the skeleton of my code.
Sub chrt_chck()
Dim rng As Range
Dim x As Long
Set rng = Range("A1:F10")
x = ActiveSheet.rng.ChartObjects.Count
If x > 1 Then
'select and delete all charts in range
End If
If x = 1 Then
'select that chart and update format
Else
'create chart and set format
End If
End Sub
Please, try the next way:
Sub chrt_chck()
Dim rng As Range, chO As ChartObject, x As Long, arrChO() As ChartObject, k As Long, El
Set rng = Range("B2:D15") ' Range("A1:F10")
ReDim arrChO(ActiveSheet.ChartObjects.count - 1)
For Each chO In ActiveSheet.ChartObjects
If Not Intersect(chO.TopLeftCell, rng) Is Nothing Then
x = x + 1
Set arrChO(k) = chO: k = k + 1
End If
Next
If x > 1 Then
'select and delete all charts in range
For Each El In arrChO
Debug.Print El.name
El.Delete
Next
End If
If x = 1 Then
'select that chart and update format
With arrChO(0)
.Select
Debug.Print .name
'do wahtever needed with the chart...
End With
Else
'create chart and set format
End If
End Sub
It counts all chart objects having their Top Left corner inside the rng Range.
Hi I'm trying to work through a table downloaded from a 3rd party that uses ticks (shapes) rather than text in the cells. The shapes have no textframe characters. I can't filter the ticks in excel so I want to replace then with text e.g. Yes. Here is my working code but get run time error 438 due to object errors I have tried the excel vba object model but can't get it to work. The VBE doesn't seem to have the Selection.ShapeRange
https://learn.microsoft.com/en-us/office/vba/api/excel.shape
https://learn.microsoft.com/en-us/office/vba/api/excel.shaperange
Here is my code
Sub ReplaceShapeswithYes()
' Inserts text where a shape exists
Dim ws As Worksheet
Dim NumRow As Integer
Dim iRow As Integer
Dim NumShapes As Long
Set ws = ActiveSheet
NumRow = ws.UsedRange.Rows.Count
For iRow = 2 To NumRow
Cells(iRow, 10).Select
'NumShapes = ActiveWindow.Selection.ShapeRange.Count ' tried both
NumShapes = Windows(1).Selection.ShapeRange.Count
If NumShapes > 0 Then
Cells(iRow, 10).Value = "Yes"
End If
Next iRow
End Sub
Many thanks
To get all shapes of a sheet, simply loop over the Shapes-collection of the sheet.
The text of a shape can be read with TextFrame.Characters.Text, but to be on the save side, you will need to check if a shape has really text (there are shapes that don't have any), see https://stackoverflow.com/a/16174772/7599798
To get the position withing a sheet, use the TopLeftCell-property.
The following code will copy the text of all shapes into the sheet and delete the shapes:
Sub shapeToText(Optional ws As Worksheet = Nothing)
If ws Is Nothing Then Set ws = ActiveSheet
Dim sh As Shape
For Each sh In ws.UsedRange.Shapes
If Not sh.TextFrame Is Nothing Then
If sh.TextFrame2.HasText Then
Dim s As String
s = sh.TextFrame.Characters.Text
sh.TopLeftCell = s
sh.Delete
End If
End If
Next
End Sub
This has done the trick
Sub ReplaceShapes()
'Replace all ticks with text
Dim NoShapes As Long
Dim iShape As Long
Dim ws As Worksheet
Dim r As Range
Dim Shp As Shape
Set ws = ActiveSheet
NoShapes = ws.Shapes.Count
For iShape = NoShapes To 1 Step -1:
Set Shp = ws.Shapes(iShape)
Set r = Shp.TopLeftCell
r.Value = "Yes"
Next iShape
End Sub
I'm trying to colour my pie chart segments, according to the cells the data is drawn from, using Excel 2016.
I pinched code from a YouTube video but this is hard to read in places (1, l & i are particularly hard to differentiate) so I'm not convinced I have it right.
Private Sub SheetActivate(ByVal Sh As Object)
Dim cht As ChartObject
Dim i As Integer
Dim vntValues As Variant
Dim s As String
Dim mySeries As Series
For Each cht In ActiveSheet.ChartObjects
For Each mySeries In cht.Chart.SeriesCollection
If mySeries.ChartType <> xlPie Then GoTo SkipNotPie
s = Split(mySeries.Formula, ",")(2)
vntValues = mySeries.Values
For i = 1 To UBound(vntValues)
mySeries.Points(i).Interior.Color = Range(s).Cells(i).Interior.Color
Next l
SkipNotPie:
Next mySeries
Next cht
End Sub
Update: here is a snip showing the charts - I'm trying to update the chart segments to represent the cell fill colours in the second column.
With minor adjustments, this worked fine:
Private Sub SheetActivate()
Dim cht As ChartObject
Dim i As Long
Dim vntValues As Variant
Dim s As String
Dim mySeries As Series
For Each cht In ActiveSheet.ChartObjects
For Each mySeries In cht.Chart.SeriesCollection
If mySeries.ChartType <> xlPie Then GoTo SkipNotPie
s = Split(mySeries.Formula, ",")(2)
vntValues = mySeries.Values
For i = 1 To UBound(vntValues)
mySeries.Points(i).Interior.Color = Range(s).Cells(i).Interior.Color
Next i
SkipNotPie:
Next mySeries
Next cht
End Sub
Make sure you don't have Option Base 1 at the top of the module. If you do, then change
s = Split(mySeries.Formula, ",")(2)
to
s = Split(mySeries.Formula, ",")(3)
I haven't used Option Base 1 since I learned to count starting at zero.
I have a VBA code (below) that sets the min and max x-axis values to a specified cell (B4 and B15). However, I have many plots in my workbook, and all need a different min and max x-axis range. I want a VBA code that goes to the plotted x-axis range and then finds the min and max value in that range and sets the axis to those values. How can I alter the code below to do that?
Sub Resize_Fonts()
Dim Sht As Worksheet
Dim Cht As ChartObject
For Each Sht In ActiveWorkbook.Sheets
For Each Cht In Sht.ChartObjects
Cht.Chart.ChartArea.Font.Size = 9
Cht.Chart.ChartArea.Font.Name = "Cambria"
Cht.Chart.ChartArea.Border.LineStyle = xlNone
Cht.Chart.Axes(xlValue).MinimumScale = 0
Cht.Chart.Axes(xlCategory).MinimumScale = Range("B4").Value
Cht.Chart.Axes(xlCategory).MaximumScale = Range("B15").Value
Next Cht
Next Sht
End Sub
If the min and max are always within the range B14:B15 on Sht you can use:
Cht.Chart.Axes(xlCategory).MinimumScale = worksheetfunction.Min(Sht.Range("B4:B15"))
Cht.Chart.Axes(xlCategory).MaximumScale = worksheetfunction.Max(Sht.Range("B4:B15"))
Try using the WorksheetFunction.Min for this.
Cht.Chart.Axes(xlCategory).MinimumScale = WorksheetFunction.Min(Columns(2))
Cht.Chart.Axes(xlCategory).MaximumScale = WorksheetFunction.Max(Columns(2))
This assumes the x-axis values are in column 2.
You could add a dim count as long and put your min / max values in adjacent columns. Then increment your count in your For each loop and use Cells([row], [n+] count).value to get the cell value.
By the way, You can use:
With cht.Chart
[...]
End with
Try to use the With Cht.Chart statement, it will shorten and clear your coding style.
When looking for the Min and Max values in Column B, you need to make sure you fully qualify the Range, by adding Sht.Range.
Code
Sub Resize_Fonts()
Dim Sht As Worksheet
Dim Cht As ChartObject
For Each Sht In ActiveWorkbook.Sheets
For Each Cht In Sht.ChartObjects
With Cht.Chart
.ChartArea.Font.SIZE = 9
.ChartArea.Font.Name = "Cambria"
.cartArea.Border.LineStyle = xlNone
.Axes(xlValue).MinimumScale = 0
.Axes(xlCategory).MinimumScale = WorksheetFunction.Min(Sht.Range("B1:B" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row))
.Axes(xlCategory).MaximumScale = WorksheetFunction.Max(Sht.Range("B1:B" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row))
End With
Next Cht
Next Sht
End Sub
After reading your comments, as I first said with my other unregistered account, you can use this method:
Sub Resize_Fonts()
Dim Sht As Worksheet
Dim Cht As ChartObject
Dim count as Long
count = 2 ' For column B
For Each Sht In ActiveWorkbook.Sheets
For Each Cht In Sht.ChartObjects
With Cht.Chart
.ChartArea.Font.Size = 9
.ChartArea.Font.Name = "Cambria"
.ChartArea.Border.LineStyle = xlNone
.Axes(xlValue).MinimumScale = 0
.Axes(xlCategory).MinimumScale = Sht.Cells(4, count).Value
.Axes(xlCategory).MaximumScale = Sht.Cells(15, count).Value
End with
count = count + n ' with n your "pattern"
Next Cht
count = 2 ' reset the count when changing sheet
Next Sht
End Sub
This assume values are always row 4 and row 15.
Comment if you have any other queries
I'm trying to get the code to resize width in all data labels from the charts of a worksheet but I cannot manage to do it. Here I have the code to apply a number format and I'd want to add the width property to that (it's just valid for Excel 2013):
Sub FormatAllCharts()
Dim ChtObj As ChartObject
For Each ChtObj In ActiveSheet.ChartObjects
With ChtObj.Chart
For i = 1 To .SeriesCollection.Count
With .SeriesCollection(i)
.ApplyDataLabels
.DataLabels.NumberFormat = "0,0;-0,0;;"
End With
Next
End With
Next
End Sub
This is the code for changing the width size of data labels:
ActiveChart.FullSeriesCollection(1).DataLabels.Select
ActiveChart.FullSeriesCollection(1).Points(4).DataLabel.Select
Selection.Width = 19
Here, I have eventually found a solution:
Sub FormatAllCharts()
Dim i As Long
Dim oChtObj As ChartObject
For Each oChtObj In ActiveSheet.ChartObjects
With oChtObj.Chart
For i = 1 To .SeriesCollection.Count
With .SeriesCollection(i)
.ApplyDataLabels
.DataLabels.NumberFormat = "0,0;-0,0;;"
Values_Array = .Values
For j = LBound(Values_Array, 1) To UBound(Values_Array, 1)
.Points(j).DataLabel.Width = 19
Next
End With
Next
End With
Next
End Sub