I need to change my y-axis to Logarithmic scale, however, after doing so the horizontal lines are removed, i.e. the lines indicating which level the y-axis is at. Is there a way to add this with VBA? I used
.Axes(xlValue).ScaleType = xlScaleLogarithmic
.Axes(xlValue).LogBase = 2.7
to change the y-axis to log, however, now it looks something like this
and I want it to like something like this (this is another plot, I just want to illustrate how I want the horizontal lines).
Note that the horizontal lines are only removed when I change to log scale.
Here is the code that I
Dim dataSheet As Worksheet
Set dataSheet = Sheets("cudfFactor")
Dim CurrentChart As Chart
Dim Subtitle As Variant
Set CurrentChart = ActiveSheet.Shapes.AddChart2(227, xlLine).Chart
Dim startRow As Integer
Dim endRow As Integer
startRow = 1
endRow = dataSheet.Range(dataSheet.Cells(2, 2), dataSheet.Cells(2, 2)).End(xlDown).Row
With CurrentChart
With .Parent
.Width = 430
.Height = 290
.left = 500
.top = topD
End With
.ChartArea.ClearContents
.ChartTitle.Text = "Accumulated Top Quintile Log Returns"
Dim i As Integer
For i = 1 To 6
.SeriesCollection.NewSeries
.FullSeriesCollection(i).Name = dataSheet.Cells(startRow, i + 1)
.FullSeriesCollection(i).XValues = dataSheet.Range(dataSheet.Cells(startRow + 1, 1), dataSheet.Cells(endRow, 1))
.FullSeriesCollection(i).Values = dataSheet.Range(dataSheet.Cells(startRow + 1, i + 1), dataSheet.Cells(endRow, i + 1))
Next i
.SetElement (msoElementLegendBottom)
.Axes(xlValue).MaximumScale = 300
.Axes(xlValue).MinimumScale = 80
.Axes(xlValue).ScaleType = xlScaleLogarithmic
.Axes(xlValue).LogBase = 2.7
End With
If you need the data, please let me know.
Thanks in advance for any help.
Related
I have a spreadsheet that involves the user resizing some rectangular shapes, which are set on a background of an Excel grid with column width = row height = 10pixels. The purpose of this background is to give a scale to the plan, which is made by the shapes; in this case, one column or row represents 10cm - there is a thick border after every 10 cells to represent a metre:
When the user resizes the rectangle, I would like the text inside the rectangle to display the dimensions, according to the scale of the plan. I have read many articles about how the shapes dimensions are provided in points, and the columns and rows in pixels (or a unit based on the font), and have found the conversion function between them, but it does not seem to give the results I would expect - the values for the width and height depend on the level of zoom, giving smaller and smaller results as I zoom out, even though the displayed pixel width remains the same.
Is there a way to consistently convert the pixel units of the grid to the points unit of the shapes such that I can essentially count how many column widths and row heights comprise the shape dimensions? Here is the macro I have written so far:
Option Explicit
Dim sh As Shape
Dim dbPx_Per_Unit As Double
Dim strUnit As String
Dim UserSelection As Variant
Dim strText As String
Dim strWidth As String
Dim strHeight As String
Sub LabelShapeSize()
Set UserSelection = ActiveWindow.Selection
'is selection a shape?
On Error GoTo NoShapeSelected
Set sh = ActiveSheet.Shapes(UserSelection.Name)
On Error Resume Next
'pixels are the units for the columns and rows
'dbPx_Per_Unit = InputBox("there are this many pixels per unit:", "Conversion Rate", 10)
dbPx_Per_Unit = 100
'strUnit = InputBox("Unit Name:", "Units", "M")
strUnit = "M"
With sh
'Width and length is measured in points, so we need to convert the points to pixels to get the actual size
strWidth = Format(Application.ActiveWindow.PointsToScreenPixelsX(.Width) / dbPx_Per_Unit, "#,##0.0")
strHeight = Format(Application.ActiveWindow.PointsToScreenPixelsY(.Height) / dbPx_Per_Unit, "#,##0.0")
'this is our message that will be in the shape
strText = strWidth & strUnit & " x " & strHeight & strUnit
With .TextFrame2
.VerticalAnchor = msoAnchorMiddle
With .TextRange.Characters
.ParagraphFormat.FirstLineIndent = 0
.ParagraphFormat.Alignment = msoAlignCenter
.Text = strText
'I'll sort something out for dark shapes at some point, but for now let's just write in black ink
With .Font
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1
.Fill.Solid
.Size = 10
End With
End With
End With
End With
Exit Sub
'No shape error
NoShapeSelected:
MsgBox "You must select a shape to calculate dimensions!", vbCritical, "Object not set to an instance of a Nobject"
End Sub
****** for completeness, here is the final script I wrote implementing the solution in the answer below ******
Option Explicit
Dim sh As Shape
Dim db_Cols_Per_Unit As Double
Dim strUnit As String
Dim strText As String
Dim userSelection As Variant
Dim ws As Worksheet
Dim clrBackground As Long
Dim leftCol As Integer
Dim colWidth As Integer
Dim topRow As Integer
Dim rowHeight As Integer
Sub LabelShapeSize()
Set userSelection = ActiveWindow.Selection
Set ws = ActiveSheet
db_Cols_Per_Unit = 10
strUnit = "M"
'is selection a shape?
On Error GoTo NoShapeSelected
Set sh = ActiveSheet.Shapes(userSelection.Name)
On Error Resume Next
topRow = 1
rowHeight = 0
leftCol = 1
colWidth = 0
With sh
While ws.Cells(1, leftCol).Left <= .Left 'Move left until we find the first column the shape lies within
leftCol = leftCol + 1
Wend
While ws.Cells(1, leftCol + colWidth).Left <= .Left + .Width 'Continue moving left until we find the first column the shape does not lie within
colWidth = colWidth + 1
Wend
While ws.Cells(topRow, 1).Top <= .Top 'Move down until we find the first row the shape lies within
topRow = topRow + 1
Wend
While ws.Cells(topRow + rowHeight, 1).Top <= .Top + .Height 'Continue moving down until we find the first row the shape does not lie within
rowHeight = rowHeight + 1
Wend
'this is our message that will be in the shape
strText = Format(colWidth / db_Cols_Per_Unit & strUnit, "#,##0.0") & " x " & rowHeight / Format(db_Cols_Per_Unit, "#,##0.0") & strUnit
clrBackground = .Fill.ForeColor.RGB
With .TextFrame2
.VerticalAnchor = msoAnchorMiddle
With .TextRange.Characters
.ParagraphFormat.FirstLineIndent = 0
.ParagraphFormat.Alignment = msoAlignCenter
.Text = strText
With .Font
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = ContrastColor(clrBackground)
.Fill.Solid
.Size = 10
End With
End With
End With
End With
Exit Sub
'No shape error
NoShapeSelected:
MsgBox "You must select a shape to calculate dimensions!", vbCritical, "Object not set to an instance of a Nobject"
End Sub
Function ContrastColor(clrBackground As Long) As Long
Dim brightness As Integer
Dim luminance As Double
Dim r As Integer
Dim g As Integer
Dim b As Integer
r = clrBackground Mod 256
g = (clrBackground \ 256) Mod 256
b = (clrBackground \ 65536) Mod 256
luminance = ((0.199 * r) + (0.587 * g) + (0.114 * b)) / 255
If luminance > 0.5 Then
brightness = 0
Else
brightness = 255
End If
ContrastColor = RGB(brightness, brightness, brightness)
End Function
thanks to #Gacek answer in this question for the luminance function.
I believe your best bet would be to make use of the Left, Top, Width, and Height cell properties. They'll tell you the value in Excel's weird format (the same units as used by the shapes), so you won't need to do any conversions.
The downside is that as far as I know of, there's no way to get the row/column that exists at a given top/left value, so you need to search through all the rows/columns until you find the one that matches your shape's boundaries.
Here's a quick example (there's probably an off-by-one error in here somewhere)
Dim UserSelection As Variant
Dim ws As Worksheet
Dim sh As Shape
Dim leftCol As Integer
Dim colWidth As Integer
Dim topRow As Integer
Dim rowHeight As Integer
Set ws = ActiveSheet
Set UserSelection = ActiveWindow.Selection
Set sh = ActiveSheet.Shapes(UserSelection.Name)
leftCol = 1
colWidth = 0
While ws.Cells(1, leftCol).Left <= sh.Left 'Move left until we find the first column the shape lies within
leftCol = leftCol + 1
Wend
While ws.Cells(1, leftCol + colWidth).Left <= sh.Left + sh.width 'Continue moving left until we find the first column the shape does not lie within
colWidth = colWidth + 1
Wend
topRow = 1
rowHeight = 0
While ws.Cells(topRow, 1).Top <= sh.Top 'Move down until we find the first row the shape lies within
topRow = topRow + 1
Wend
While ws.Cells(topRow + rowHeight, 1).Top <= sh.Top + sh.height 'Continue moving down until we find the first row the shape does not lie within
rowHeight = rowHeight + 1
Wend
MsgBox "Shape is " & colWidth & " columns wide by " & rowHeight & " rows high"
I have a list of data and I need to generate a chart for every two lines and give a chart title associated to the 1st line. Example of the data is:
Example
And so on.
The code I am using to create the charts is:
Sub loopChart()
Dim mychart As Chart
Dim myRange As Range
Dim c As Integer
Dim r As Integer
Dim s As Integer
Dim ttl As String
r = 2
While r <= 10 '1=dataSource1, 4=dataSource2, 7=dataSource3
'set data source for the next chart
With Worksheets("Sheet9")
Set myRange = .Range(.Cells(r, 2), .Cells(r + 1, 14))
End With
'create chart
Sheets("Chart").Select
ActiveSheet.Shapes.AddChart.Select
With ActiveChart
ttl = Range("A" & r)
.ChartType = xlLineMarkers 'xlLine
.SetSourceData Source:=myRange, PlotBy:=xlRows 'sets source data for graph including labels
.SetElement (msoElementLegendRight) 'including legend
.HasTitle = True
'dimentions & location:
.Parent.Top = 244 'defines the coordinates of the top of the chart
'.Parent.Left = r * 150 'defines the coordinates for the left side of the chart
.Parent.Height = 200
.Parent.Width = 300
.ChartTitle.Formula = ttl
End With
r = r + 2
Wend
End Sub
So, the 1st chart that generates should get the title on row 2, next chart should have title of row 4...
I always get the Chart title on 1st chart that generates but not on any of the other charts. Can anyone please help me on this?
Please fix below.
ttl = Range("A" & r)
to
ttl = Worksheets("Sheet9").Range("A" & r).Value
I think #Dy.Lee answer will do the trick but to go a bit further :
Try avoiding using .select
Proposed workaround :
Sub loopChart()
Dim Ch As Chart
Dim Sh1 As Worksheet: Set Sh1 = Sheets("Sheet9")
Dim Sh2 As Worksheet: Set Sh2 = Sheets("Chart")
Dim L As Integer
L = 0
For i = 2 To 18 Step 2
Set Ch = Sh2.Shapes.AddChart.Chart
Ch.SetSourceData Sh1.Range(Sh1.Cells(i, 2), Sh1.Cells(i + 1, 14))
Ch.ChartType = xlLineMarkers
Ch.SetElement (msoElementLegendRight)
Ch.HasTitle = True
Ch.Parent.Top = 244
Ch.Parent.Height = 200
Ch.Parent.Width = 300
Ch.Parent.Left = L
Ch.ChartTitle.Caption = Sh1.Cells(i, 1).Value
L = L + 300
Next i
End Sub
Your code will create each graph at the same location so you'll see only one (the last one) hence the Ch.Parent.Left line with variable value.
I'm noob in vba (Excel macros). I need to add somes charts automatically in the same WorkSheet. This is my code:
Sub runChart()
Dim xchart As Chart
Dim nameSheet As String
nameSheet = ActiveSheet.Name
Dim x As Integer
Dim firstIndex As Integer
Dim firstValue As Integer
Dim actualValue As Integer
Dim actualIndex As Integer
Dim rChart1 As Range
Dim rChart2 As Range
MsgBox nameSheet
firstIndex = 2
actualIndex = 2
firstValue = Cells(2, 1)
actualValue = Cells(2, 1)
Do
Do
actualIndex = actualIndex + 1
actualValue = Sheets(nameSheet).Cells(actualIndex, 1)
Loop Until firstValue <> actualValue
Set rChart1 = Range(Sheets(nameSheet).Cells(firstIndex, "E"), Sheets(nameSheet).Cells(actualIndex - 1, "E"))
Set rChart1 = Union(rChart1, Range(Sheets(nameSheet).Cells(firstIndex, "J"), Sheets(nameSheet).Cells(actualIndex - 1, "J")))
Dim nameChart As String
nameChart = CStr(Sheets(nameSheet).Cells(firstIndex, 5)) & " - " & Sheets(nameSheet).Cells(actualIndex, 5) & " " & CStr(Sheets(nameSheet).Cells(firstIndex, 1))
Set xchart = Charts.Add
With xchart
.Name = nameChart
.ChartType = xlColumnClustered
.SetSourceData rChart1
.Location Where:=xlLocationAsObject, Name:=nameSheet
'position and size chart
.ChartArea.Top = 10 'this position is a example
.ChartArea.Left = 1700 'this position is a example
.ChartArea.Height = 400 'this size is a example
.ChartArea.Width = 750 'this size is a example
End With
firstValue = Sheets(nameSheet).Cells(actualIndex, 1)
firstIndex = actualIndex
Loop Until (Sheets(nameSheet).Cells(actualIndex, 1) = vbNullString)
End Sub
So, my problem happens is in .ChartArea.left = 1700. The program says :
The specified dimension is not valid for the current chart type
anyone has any idea what 's happening? Thanks for your time :)
The ChartArea is the overall rectangle containing the chart within its parent ChartObject (the shape that contains the embedded chart). The position and size of the ChartArea are read only. But that's okay, you want to position and resize the ChartObject, which is the chart's .Parent.
With xchart
'position and size chart
.Parent.Top = 10 'this position is a example
.Parent.Left = 1700 'this position is a example
.Parent.Height = 400 'this size is a example
.Parent.Width = 750 'this size is a example
End With
I am extremely new to excel vba and am using this first attempt as a learning experience. I am hoping to make a matrix of scatterplots in a separate sheet from the sheet they are taking the data from.
So heres a kind of schematic of the graphs I would like to be generated in an excel sheet. This represents a single satterplot [x-axis(ColumnletterRownumber), y-axis(ColumnletterRownumber)]
[(S2:S372),(AW2:AW372)] [(T2:T372),(AW2:AW372)] [(U2:U372),(AW2:AW372)]
[(S2:S372),(AX2:AX372)] [(T2:T372),(AX2:AX372)] [(U2:U372),(AX2:AX372)]
[(S2:S372),(AY2:AY372)] [(T2:T372),(AY2:AY372)] [(U2:U372),(AY2:AY372)]
[(S2:S372),(AZ2:AZ372)] [(T2:T372),(AZ2:AZ372)] [(U2:U372),(AZ2:AZ372)]
So those would be the scatterplots on the next sheet. Obviously I need a lot more graphs than that but that should give you an idea.
Here's what I got so far:
Sorry in advance for the large amount of commented out things... those are ideas I think might help but I haven't gotten them to work.
Sub SPlotMatrix1()
Application.ScreenUpdating = False
'SPlotMatrix1 Macro
'Define the Variables
'---------------------
Dim Xaxis As range
Dim Yaxis As range
''Initialize the Variables
''-------------------------
Set Xaxis = range("S2:S372")
Set Yaxis = range("AW2:AW372")
'Tell macro when to stop
'-----------------------
Dim spot As Long
spot = 0
Do Until spot > 50
Sheets("2ndFDAInterimData").Select
''MAIN LOOP
'Graph1
'-------
'Selection Range
range("S2:S372,AW2:AW372").Select
'range("Xaxis,Yaxis").Select
'range("AW1:AW372",S1:S372").Offset(0, rng).Select
'range("AW1:AW372", 0).Select
'range("0,S1:S372").Offset(0, rng).Select
range("S372").Activate
'Select Graph Range
ActiveSheet.Shapes.AddChart2(240, xlXYScatter).Select
' ActiveChart.SetSourceData Source:=range( _
"'2ndFDAInterimData'!$AW$1:$AW$372,'2ndFDAInterimData'!$S$1:$S$372")
'Graph Title
ActiveChart.SetElement (msoElementChartTitleAboveChart)
ActiveChart.FullSeriesCollection(1).Select
ActiveChart.FullSeriesCollection(1).name = "='2ndFDAInterimData'!$DL$1"
'Add Trendline
ActiveChart.Axes(xlValue).MajorGridlines.Select
ActiveChart.FullSeriesCollection(1).Trendlines.Add Type:=xlLinear, Forward _
:=0, Backward:=0, DisplayEquation:=0, DisplayRSquared:=0, name:= _
"Linear (Ave.Score)"
ActiveChart.FullSeriesCollection(1).Trendlines.Add Type:=xlLinear, Forward _
:=0, Backward:=0, DisplayEquation:=0, DisplayRSquared:=0, name:= _
"Linear (Ave.Score)"
ActiveChart.FullSeriesCollection(1).Trendlines(2).Select
Selection.DisplayRSquared = True
'Move Rsquare Label to Corner
ActiveChart.FullSeriesCollection(1).Trendlines(2).DataLabel.Select
Selection.Left = 30.114
Selection.Top = 13.546
'Format Trendline
ActiveChart.FullSeriesCollection(1).Trendlines(2).Select
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
End With
With Selection.Format.Line
.Visible = msoTrue
.DashStyle = msoLineSolid
End With
ActiveChart.ChartArea.Select
With Selection.Format.Line
.Visible = msoTrue
.Weight = 1.75
End With
'Resize Graph
ActiveChart.Parent.Height = 180
ActiveChart.Parent.Width = 239.76
'Y axis scale
ActiveChart.FullSeriesCollection(1).Select
ActiveChart.Axes(xlValue).Select
ActiveChart.Axes(xlValue).MaximumScale = 100
'Move graph to center (for the purposes of design and debugging)
ActiveChart.Parent.Cut
range("V4").Offset(spot, 0).Select
ActiveSheet.Paste
' 'Move Graph to other sheet
' ActiveChart.Parent.Cut
' Sheets("graphs").Select
' range("A1").Offset(spot, 0).Select
' ActiveSheet.Paste
spot = spot + 14
Loop
Application.ScreenUpdating = True
End Sub
I've gotten to the point where I am creating a number of the same graphs in a row or column if I want. But I can't successfully get the graphs ranges to change so that they are plotting different data.
Please help, let me know if I can further clarify. Thank you!
You can define the data with a couple simple loops. Create the chart and embellish it within the inner loop.
Sub InsertMultipleCharts()
' data particulars
Dim wksData As Worksheet
Const Xcol1 As Long = 19 ' column S
Const Xcol2 As Long = 21 ' column U
Const Ycol1 As Long = 49 ' column AW
Const Ycol2 As Long = 52 ' column AZ
Const Row1 As Long = 2
Const Row2 As Long = 372
' chart dimensions
Const FirstChartLeft As Long = 50
Const FirstChartTop As Long = 50
Const ChartHeight As Long = 180
Const ChartWidth As Long = 240
' working variables
Dim wksChart As Worksheet
Dim cht As Chart
Dim Xrange As Range
Dim Yrange As Range
Dim Xcol As Long
Dim Ycol As Long
' define sheets
Set wksData = ActiveSheet
Set wksChart = Worksheets.Add
' loop X
For Xcol = Xcol1 To Xcol2
' define x values
Set Xrange = Range(wksData.Cells(Row1, Xcol), wksData.Cells(Row2, Xcol))
' loop Y
For Ycol = Ycol1 To Ycol2
' define y values
Set Yrange = Range(wksData.Cells(Row1, Ycol), wksData.Cells(Row2, Ycol))
' insert chart
Set cht = wksChart.Shapes.AddChart2(Style:=240, XlChartType:=xlXYScatter, _
Left:=FirstChartLeft + (Xcol - Xcol1) * ChartWidth, _
Top:=FirstChartTop + (Ycol - Ycol1) * ChartHeight, _
Width:=ChartWidth, Height:=ChartHeight).Chart
' assign data to chart
cht.SetSourceData Source:=Union(Xrange, Yrange)
' chart title
cht.HasTitle = True
With cht.ChartTitle.Font
.Size = 12
.Bold = False
End With
' axis scale
cht.Axes(xlValue).MaximumScale = 100
' legend
cht.HasLegend = False
' series: name, trendline, and Rsquared
With cht.SeriesCollection(1)
.Name = "Series Name" '''' don't know where these are coming from
With .Trendlines.Add(Type:=xlLinear, DisplayRSquared:=True).DataLabel
.Format.Line.DashStyle = msoLineSolid
.Top = cht.PlotArea.InsideTop
.Left = cht.PlotArea.InsideLeft
End With
End With
Next
Next
End Sub
Macro recorder code is messy, but it gives you syntax.
Try using the macro recorder to edit an existing range so you get the code for setting the ranges for X, Y and the range name and size.
Once recorded you can swap out the new ranges as variables to get the new charts.
I am trying to make a subroutine in PowerPoint with VBA that will take 9 pictures that have been previously inserted and resized, and arrange them into 3 columns and 3 rows. I cannot figure out how to select a picture, move it, then select the next picture on the slide.
My VBA knowledge is limited mostly to using Excel, and since PowerPoint 2010 does not have a "Record Marco" button, this is my current pathetic attempt.
Sub ArrangeIn3x3()
Dim sldTemp As Slide
Dim lngTemp As Long
Dim lngCount As Long
For Each sldTemp In ActivePresentation.Slides
For lngCount = sldTemp.Shapes.Count To 1 Step -1
With sldTemp.Shapes(lngCount)
.LockAspectRatio = msoTrue
.Width = 3 * 72
.Left = (x + 0.2) * 72
x = x + 1
.Top = (y + 0.75) * 72
y = y + 1
End With
Next
Next
End Sub
Thank You.
This has your 3x3 grid hardcoded; you could extend it to take the number of rows/columns as parameters, to work out the size of the first image and supply that automatically, and any number of other enhancements, but this should do what you're after:
Sub NineUp()
Dim sngInterRowSpace As Single
Dim sngInterColSpace As Single
Dim lRowCount As Long
Dim lColCount As Long
Dim sngLeft As Long
Dim sngTop As Long
Dim sngImageWidth As Single
Dim sngImageHeight As Single
Dim lShapeCount As Long '
' Define spacing between rows/columns
sngInterRowSpace = 0.2 * 72
sngInterColSpace = 0.2 * 72
' change these dimensions to match those
' of your images
sngImageWidth = 2.36 * 72
sngImageHeight = 2.17 * 72
lShapeCount = 1
sngTop = sngInterRowSpace
For lRowCount = 1 To 3
sngLeft = sngInterColSpace
For lColCount = 1 To 3
With ActivePresentation.Slides(1).Shapes(lShapeCount)
.Left = sngLeft
.Top = sngTop
sngLeft = sngLeft + sngImageWidth + sngInterColSpace
lShapeCount = lShapeCount + 1
End With
'sngTop = sngTop + sngImageHeight + sngInterRowSpace
Next
sngTop = sngTop + sngImageHeight + sngInterRowSpace
Next
End Sub