I have this code but when the VBA copies and pastes the charts on the Excelsheet, the Charts overlap.
Is there a way to arrange them in 1 column without overlapping?
Thank you!
Sub Test1()
Dim cht As Excel.ChartObject
Worksheets("ChartObjects").ChartObjects.Delete
For Each Sheet In ActiveWorkbook.Worksheets
If Sheet.Name <> "ChartObjects" Then
Sheet.Select
For Each cht In Sheet.ChartObjects
cht.Select
cht.Copy
Sheets("ChartObjects").Select
Range("C5").Select
ActiveSheet.Paste
Next
End If
Next Sheet
End Sub
You can use the .Top and .Left properties of the cell, and the .Top and .Height properties of each ChartObject to align each successive chart with the previous chart's bottom:
Sub foo()
Dim cht As ChartObject
Dim newCht As ChartObject
Dim sht As Worksheet
Dim chtSht As Worksheet
Dim top As Double
Dim left As Double
'Define the destination worksheet
Set chtSht = ActiveWorkbook.Worksheets("ChartObjects")
'Define the starting parameter for the charts
With chtSht.Range("C5")
top = .top
left = .left
End With
'Iterate the sheets in the workbook
For Each sht In ActiveWorkbook.Worksheets
'Ignore the chtSheet
If Not sht.Name = chtSht.Name Then
'Iterate the charts in each worksheet
For Each cht In sht.ChartObjects
'Copy the chart
cht.Copy
'Paste it in to the destination sheet
chtSht.Paste
'Get a handle on the chart we just pasted
Set newCht = chtSht.ChartObjects(chtSht.ChartObjects.Count)
'Assign the top location of this chart
newCht.top = top
newCht.left = left
'Add with the height of this chart to determine the "top" for the next chart
top = newCht.top + newCht.Height
Next
End If
Next
End Sub
Related
I have 10 sheets. Eachs sheet has x-values and y-values which I want to plot in ONE xy-scatter plot. I wrote the code below. It works for one sheet but not for all the sheets. Additionally, I dont know how to name each series with a specific name (it can be references to a particular cell in each sheet). Kindly note that on each sheet; x-values, y-value are exactly starting and end in the same cell reference. Same is true for series name cell reference.
Sub PlotPcVsSwAllSheets()
Dim ch As Chart
Dim Sw As Range
Dim Pcres As Range
Dim ws As Worksheet
Set ch = ActiveSheet.Shapes.AddChart(xlXYScatter).Chart
For Each ws In Worksheets
Set ws.Sw = ws.Range("C23", Range("C23").End(xlDown))
Set ws.Pcres = ws.Range("AA23", Range("AA23").End(xlDown))
With ch
ch.SetSourceData Source:=Union(ws.Sw, ws.Pcres)
End With
Next ws
End Sub
You need to add each series one by one.
Sub PlotPcVsSwAllSheets()
Dim ch As Chart
Dim Sw As Range
Dim Pcres As Range
Dim ws As Worksheet, wb As Workbook
Set wb = ThisWorkbook
Set ch = ActiveSheet.Shapes.AddChart(xlXYScatter).Chart
'remove any series added by default
Do While ch.SeriesCollection.Count > 0
ch.SeriesCollection(1).Delete
Loop
For Each ws In wb.Worksheets
Set Sw = ws.Range("C23", ws.Range("C23").End(xlDown))
Set Pcres = Sw.EntireRow.Columns("AA") 'safer
With ch.SeriesCollection.NewSeries
.XValues = Sw
.Values = Pcres
.Name = ws.Range("A3").Value 'for example
End With
Next ws
End Sub
I need to create Bar chart in Excel VBA. I used the code below, but when I am ADDING or DELETING A ROW it is not working.
I need that chart on fixed range (K1). Because when I am calculating for the second time it creates another chart.
How can I change the code to prevent a new chart being added when I adjust the data source?
Private Sub CommandButton2_Click()
Sheets("Sheet7").Range("F2:H12").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlBarClustered
ActiveChart.SetSourceData Source:=Range("Sheet7!$F$2:$H$12")
ActiveChart.SeriesCollection(1).Name = "=Sheet7!$G$1"
ActiveChart.SeriesCollection(2).Name = "=Sheet7!$H$1"
End Sub
In the sample code below it checks to see if a chart called TheChart already exists, and if not, creates a new one. You can now add and remove rows and the chart should will update. Additionally, if you add a new row at the bottom and click the button it will redraw TheChart without creating a new one.
The chart is always located at the top-left of K1 per the rngChartTopLeft variable - which you can adjust if required.
The code assumes that it is running in a Sheet module (hence Set ws = Me) and if you were running it in a standard module you can set the sheet with Set ws = ThisWorkbook.Worksheets("your_sheet").
Option Explicit
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim chto As ChartObject
Dim rngChartTopLeft As Range
Dim rngData As Range
' assumes the code is in a sheet object
Set ws = Me
' top left of chart
Set rngChartTopLeft = ws.Range("K1")
' create chart or get existing chart
If ws.ChartObjects.Count = 0 Then
Set chto = ws.ChartObjects.Add( _
Left:=rngChartTopLeft.Left, _
Width:=500, _
Top:=rngChartTopLeft.Top, _
Height:=500)
chto.Name = "TheChart"
Else
Set chto = ws.ChartObjects("TheChart")
End If
' set chart type
chto.Chart.ChartType = xlBarClustered
' get data range per last row of data
Set rngData = ws.Range("F2:G" & ws.Cells(ws.Rows.Count, "G").End(xlUp).Row)
' set new chart range
chto.Chart.SetSourceData rngData
End Sub
please check the below code:
Option Explicit
Private Sub CommandButton1_Click()
Dim mychart As Shape
Dim lastrow As Long
lastrow = Sheet7.Cells(Rows.Count, "F").End(xlUp).Row
For Each mychart In ActiveSheet.Shapes
If mychart.Name = "CommandButton1" Then GoTo exit_
mychart.Delete
exit_:
Next
Sheets("Sheet7").Range("F2:H" & lastrow).Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlBarClustered
ActiveChart.SetSourceData Source:=Range("Sheet7!$F$2:$H$" & lastrow)
ActiveChart.SeriesCollection(1).Name = "=Sheet7!$G$1"
ActiveChart.SeriesCollection(2).Name = "=Sheet7!$H$1"
End Sub
Have been using this blog to link chart axis to cell values.
Sub ScaleAxes()
Dim wks As Worksheet
Set ws = Worksheets("AXIS")
Set cht = ActiveWorkbook.ChartObjects("ChartName1","ChartName2")
For Each cht In ActiveWorkbook.ChartObjects
cht.Activate
With ActiveChart.Axes(xlCategory, xlPrimary)
.MaximumScale = ws.Range("$B$12").Value
.MinimumScale = ws.Range("$B$11").Value
.MajorUnit = ws.Range("$B$13").Value
End With
Next cht
End Sub
I'm aiming for the values a single worksheet with axis values to update multiple charts on different worksheets. Most examples are using charts on the same worksheet. I currently get error 438 - any ideas?
Try the code below, explanations inside the code as comments:
Option Explicit
Sub ScaleAxes()
Dim Sht As Worksheet
Dim ws As Worksheet
Dim chtObj As ChartObject
Dim ChtNames
Set ws = Worksheets("AXIS")
' you need to get the names of the charts into an array, not ChartObjects array
ChtNames = Array("ChartName1", "ChartName2")
' first loop through all worksheet
For Each Sht In ActiveWorkbook.Worksheets
' loop through all ChartObjects in each worksheet
For Each chtObj In Sht.ChartObjects
With chtObj
'=== use the Match function to check if current chart's name is found within the ChtNames array ===
If Not IsError(Application.Match(.Name, ChtNames, 0)) Then
With .Chart.Axes(xlCategory, xlPrimary)
.MaximumScale = ws.Range("B12").Value
.MinimumScale = ws.Range("B11").Value
.MajorUnit = ws.Range("B13").Value
End With
End If
End With
Next chtObj
Next Sht
End Sub
I am running a macro to resize my plot area to make all graphs uniform within a report. However, when resizing the plot area the Chart Data Table resizes as well and the Labels for the rows in the Data Table become text wrapped. This issue is fixed if I manually resize the Plot Area slightly and then the text is fixed and is autofit and no longer text wrapped to take up three or four lines. Any way to fix this? This is my current code.
Sub Color_Loop_Series()
Dim sht As Worksheet
Dim CurrentSheet As Worksheet
Dim cht As ChartObject
Dim ser As Series
For Each sht In ActiveWorkbook.Worksheets
For Each cht In sht.ChartObjects
cht.Activate
ActiveChart.ChartType = xlLineMarkers
ActiveChart.Legend.Position = xlLegendPositionBottom
ActiveChart.Legend.Font.Size = 9
ActiveChart.PlotArea.Select
Selection.Width = 380
Selection.Left = 11
Selection.Top = 3
Selection.Height = 250
ActiveChart.Axes(xlValue).AxisTitle.Position = xlAxisPositionLeft
ActiveChart.DataTable.Font.Size = 5.5
Next cht
Next sht
End Sub
I was able to duplicate your problem using Excel 2010 by recording a macro while moving the plot area. When running the recorded macro the data table legend resized and text wrapped. I was not able to find any direct handle for the data table legend but did find that both .Left and .InsideLeft affect word wrapping.
Here is your code, modified a little to remove all Active statements.
Sub Color_Loop_Series()
Dim sht As Worksheet
Dim CurrentSheet As Worksheet
Dim cht As ChartObject
Dim ser As Series
For Each sht In ActiveWorkbook.Worksheets
For Each cht In sht.ChartObjects
With cht.Chart
.ChartType = xlLineMarkers
.Legend.Position = xlLegendPositionBottom
.Legend.Font.Size = 9
.DataTable.Font.Size = 5.5
.Axes(xlValue).AxisTitle.Position = xlAxisPositionLeft
End With
With cht.Chart.PlotArea
.Width = 380
.Height = 250
.Left = 11
.Top = 3
.InsideLeft = 80 '<- Adjust this value
End With
Next cht
Next sht
End Sub
Results when using .InsideLeft
Results when not using .InsideLeft
I have the following VBA code that works to export a range of cells into a jpeg into a specified folder. I would like to have it loop through all worksheets in one workbook.
I need help looping this code through all open workbooks. I believe I will need to:
Dim WS As Worksheet, then set up an If statement, insert the below code, end the if statement, then at the end put a Next WS for it to actually loop through. My problem is, is that I keep getting a 91 error when I try to combine my if statement, For Each WS In ThisWorkbook.Sheets If Not WS.Name = "Sheet2" Then, with my code below.
The following code works in one worksheet at a time.
Sub ExportAsImage()
Dim objPic As Shape
Dim objChart As Chart
Dim i As Integer
Dim intCount As Integer
'copy the range as an image
Call ActiveSheet.Range("A1:F2").CopyPicture(xlScreen, xlPicture)
'remove all previous shapes in the ActiveSheet
intCount = ActiveSheet.Shapes.Count
For i = 1 To intCount
ActiveSheet.Shapes.Item(1).Delete
Next i
'create an empty chart in the ActiveSheet
ActiveSheet.Shapes.AddChart
'select the shape in the ActiveSheet
ActiveSheet.Shapes.Item(1).Select
ActiveSheet.Shapes.Item(1).Width = Range("A1:F2").Width
ActiveSheet.Shapes.Item(1).Height = Range("A1:F2").Height
Set objChart = ActiveChart
'clear the chart
objChart.ChartArea.ClearContents
'paste the range into the chart
objChart.Paste
'save the chart as a JPEG
objChart.Export ("C:\Users\------\Desktop\Test\" & Range("B2").Value & ".jpg")
'remove all shapes in the ActiveSheet
intCount = ActiveSheet.Shapes.Count
For i = 1 To intCount
ActiveSheet.Shapes.Item(1).Delete
Next i
End Sub
Add this to your module:
Sub MAIN()
Dim sh As Worksheet
For Each sh In Sheets
sh.Activate
Call ExportAsImage
Next sh
End Sub
and run it. (there is no need to modify your code)