I am learning to use VBA for excel in Excel 2016. At the moment I am working through an assignment on this website: http://www.homeandlearn.org/vba_charts_and_user_forms.html in which I want to show a scatter-plot of one of the football teams' results. This is done by selecting the team with a combobox in a user form.
The result of the code (see below) ought to be a scatterplot with One line and a title, like this:
http://www.homeandlearn.org/images/vba_charts/chart_arsenal.gif (cannot upload it for some reason)
However, this is the result of my code.
How is it possible that, with the exact same code as on the website, the Chart isn't able to show the selected data and title? I also wonder where the fifth series came from, since I only have four columns.
The code is as follows (and unique to the code described on the website):
Private Sub cmdLoad_Click()
If cbSelect.Text = "Select a chart" Then
MsgBox "Please select a chart"
Exit Sub
End If
Dim MyChart As Chart
Dim ChartData As Range
Dim ChartIndex As Integer
Dim ChartName As String
ChartIndex = cbSelect.ListIndex
Select Case ChartIndex
Case 0
Set ChartData = ActiveSheet.Range("B2:B20")
ChartName = ActiveSheet.Range("B1").Value
Case 1
Set ChartData = ActiveSheet.Range("C2:C20")
ChartName = ActiveSheet.Range("C1").Value
Case 2
Set ChartData = ActiveSheet.Range("D2:D20")
ChartName = ActiveSheet.Range("D1").Value
Case 3
Set ChartData = ActiveSheet.Range("E2:E20")
ChartName = ActiveSheet.Range("E1").Value
End Select
Application.ScreenUpdating = False
Set MyChart = ActiveSheet.Shapes.AddChart(xlXYScatterLines).Chart
MyChart.SeriesCollection.NewSeries
MyChart.SeriesCollection(1).Name = ChartName
MyChart.SeriesCollection(1).Values = ChartData
MyChart.SeriesCollection(1).XValues = ActiveSheet.Range("A2:A20")
'Save chart as an image, remove the chart, then set updating screen to ON'
Dim imageName As String
imageName = ThisWorkbook.Path & "\gs16_pictures" & Application.PathSeparator & "TempChart.gif"
MyChart.Export Filename:=imageName, FilterName:="GIF"
ActiveSheet.ChartObjects(1).Delete
Application.ScreenUpdating = True
'Load picture in user form
UserForm1.Image1.Picture = LoadPicture(imageName)
cbSelect is initialized as follows
Private Sub UserForm_Initialize()
cbSelect.AddItem Range("B1") 'Arsenal
cbSelect.AddItem Range("C1") 'Man City
cbSelect.AddItem Range("D1") 'Newcastle
cbSelect.AddItem Range("E1") 'Cardiff
cbSelect.TextAlign = fmTextAlignCenter
End Sub
The problem was in the statement
Set MyChart = ActiveSheet.Shapes.AddChart(xlXYScatterLines).Chart
This statement automatically plotted the entire data table. To prevent it, it was necessary to explicitly state the SourceData. Below is the code which you need instead of the lines starting with MyChart.SeriesCollection
With MyChart
.SetSourceData Source:=ChartData
.HasTitle = True
.ChartTitle.Text = ChartName
.SeriesCollection(1).XValues = ActiveSheet.Range("A2:A20")
End With
I am not sure why there is a difference between Excel 2016 and the example from the website. Perhaps Excel is "smarter" than before and interpreted the source data.
Related
First of all I'm not very good at Excel macro.
After going through multiple forums, I managed to come up with a code to Crop images in a folder using Excel VBA.
the code opens up each image in Excel, paste in a chart, crop the image, resize to match the height & width and then replace the original image with the edited image.
Macro is working fine with F8 but when I run the macro fully, Images are not getting replaced with the edited one, instead it's replacing with blank image.
After digging through multiple options, the only conclusion I came up with is the macro is running fine in Excel 2013 but it's not running properly with office 365.
Can anybody help me, how to resolve this or have any better code to run?
Option Explicit
Sub ImportData()
Dim XL As Object
Dim thisPath As String
Dim BooksPAth As String
BooksPAth = "C:\Images\"
thisPath = ActivePresentation.path
Set XL = CreateObject("Excel.Application")
Run "Crop_vis", BooksPAth
End Sub
Sub DeleteAllShapes()
Dim Shp As Shape
For Each Shp In ActiveSheet.Shapes
If Not (Shp.Type = msoOLEControlObject Or Shp.Type = msoFormControl) Then Shp.Delete
Next Shp
End Sub
Sub Crop_Vis(ByVal folderPath As String)
Dim Shp As Object, path As String, sht As Worksheet, s As Shape, TempChart As String
'Dim folderPath As String
Application.ScreenUpdating = True
If folderPath = "" Then Exit Sub
Set sht = Sheet1
sht.Activate
sht.Range("A10").Activate
path = Dir(folderPath & "\*.jpg")
Do While path <> ""
DeleteAllShapes
Set Shp = sht.Pictures.Insert(folderPath & "\" & path)
' Use picture's height and width.
Set s = sht.Shapes(sht.Shapes.Count)
s.PictureFormat.CropTop = 50
s.Width = 768
s.Height = 720
'Add a temporary chart in sheet1
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=sht.Name
Selection.Border.LineStyle = 0
TempChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
With sht
'Change the dimensions of the chart to suit your need
With .Shapes(TempChart)
.Width = s.Width
.Height = s.Height
End With
'Copy the picture
s.Copy
'Paste the picture in the chart
With ActiveChart
.ChartArea.Select
.Paste
End With
'Finally export the chart
.ChartObjects(1).Chart.Export fileName:=folderPath & "\" & path, FilterName:="jpg"
'Destroy the chart. You may want to delete it...
.Shapes(TempChart).Cut
End With
path = Dir
Loop
DeleteAllShapes
Application.DisplayAlerts = False
End Sub
Before
'Finally export the chart
insert something like this, to make sure that pasting of the image into the chart has finished:
Do
If ActiveChart.Shapes.Count > 0 Then
Exit Do
End If
Loop
The problem is with the pasting. When you tell it to paste the clipboard (image) into the chart, sometimes it ignores you. When you go to export the chart, you end up with an empty image.
It's not that you have to wait for it to paste, because it's not going to - it ignored you. I have no idea why it ignores you, or why it doesn't error out when it ignores you - it just ignores you with no warning. Maybe Windows is just too busy under the hood to paste.
Basically, what you have to do is check to see if it pasted, and if not, paste again....and again....until it finally sees fit to process your instruction.
I debugged, Googled, trialed and errored and banged my head on the wall for week on this and finally ended up with this:
Sub SavePictureFromExcel(shp As Shape, SavePath As String)
Dim Imagews As Worksheet
Dim tempChartObj As ChartObject
Dim ImageFullPath As String
Set Imagews = Sheets("Image Files")
Set tempChartObj = Imagews.ChartObjects.Add(0, 0, shp.Width, shp.Height)
shp.Copy
tempChartObj.Chart.ChartArea.Format.Line.Visible = msoFalse 'No Outline
tempChartObj.Chart.ChartArea.Format.Fill.Visible = msoFalse 'No Background
Do
DoEvents
tempChartObj.Chart.Paste
Loop While tempChartObj.Chart.Shapes.Count < 1
ImageFullPath = SavePath & "\" & shp.Name & ".png"
tempChartObj.Chart.Export ImageFullPath, Filtername:="png"
tempChartObj.Delete
End Sub
I have excel with data that I'm writing in word, it is open and I try to copy chart from excel to word, without linking it, so that any other user can open it without static link to original excel file.
Sub Make4Segment(Wapp As Object)
Dim Sheet As Excel.Worksheet
Dim MyChart As ChartObject
Set Sheet = Excel.ThisWorkbook.Sheets("DOC")
Set MyChart = Excel.ThisWorkbook.Sheets("DOC").ChartObjects("C1")
MyChart.Chart.ChartArea.Copy
With Wapp.Application.Selection.Range
.PasteAndFormat Type:=wdChart
End With
End sub
I'm getting error 4605 on paste line.
Change:
.PasteAndFormat Type:=wdChart
With:
.PasteSpecial Link:=False, DataType:=26
That should paste the Object correctly with Data and Without Link
You can Try with these different datatypes if this one is not what you need.
To reader in future: I was unable to find easy copy/paste solution to copy chart form excel to word. So I created this monstrosity. It creates chart in word, copies data for chart form excel file and embeds data in word file. Loads chart settings from excel files cells for ease of changing chart appearance. Resulting word document is independent and with chart data, and can be sent to anyone.
Sub GenerateReport()
Dim Wapp As Object
'Launches word application
Set Wapp = CreateObject("Word.Application")
Wapp.Visible = True
Wapp.Activate
...
Call CreateChart(Wapp)
End Sub
'Procedure, that creates chart in Word
Sub CreateChart(Wapp As Object)
Dim Ch4y As Word.InlineShape
Dim EmChData As Excel.Worksheet
Dim SrDataSh As Excel.Worksheet
Dim FomtCh As Excel.ChartObject
Dim DbWidth As Double
Dim DbHeight As Double
Dim DbIndentCh As Double
Dim DbLineWeight As Double
Dim DbDegrees As Double
Dim DbChLeHeight As Double
Dim DbChLeWidth As Double
Dim DbChLeLeft As Double
Dim DbChLeTop As Double
Dim LnChType As Long
Dim LnXLabelSpace As Long
Dim LnYMayorUnit As Long
Dim LnYMinimumScale As Long
Dim LnChBorder As Long
Dim LnChFontSize As Long
Dim BoLegend As Boolean
Dim BoTitle As Boolean
Dim In1 As Integer
Dim In2 As Integer
Dim In3 As Integer
Dim In4 As Integer
Dim In5 As Integer
Dim In6 As Integer
Dim In7 As Integer
Dim In8 As Integer
Dim In9 As Integer
Dim StChFont As String
'Creates new chart in word
Set Ch4y = Wapp.ActiveDocument.InlineShapes.AddChart2
'Embed data in chart, to make it independent form excel
'Creates reference to place where data will be stored
Set EmChData = Ch4y.Chart.ChartData.Workbook.Worksheets(1)
'Creates reference to source data sheet
Set SrDataSh = Excel.ThisWorkbook.Sheets("DOC")
'Loads data from Excel sheet for customizability
DbWidth = SrDataSh.Range("A159").Value '490
DbHeight = SrDataSh.Range("A160").Value '180
DbIndentCh = SrDataSh.Range("A161").Value '0
LnChType = SrDataSh.Range("A162").Value '4
BoLegend = SrDataSh.Range("A163").Value 'True
BoTitle = SrDataSh.Range("A164").Value 'False
In1 = SrDataSh.Range("A166").Value '139
In2 = SrDataSh.Range("A167").Value '231
In3 = SrDataSh.Range("A168").Value '246
In4 = SrDataSh.Range("A170").Value '0
In5 = SrDataSh.Range("A171").Value '133
In6 = SrDataSh.Range("A172").Value '155
DbLineWeight = SrDataSh.Range("A173").Value '1.75
DbDegrees = SrDataSh.Range("A174").Value '90
LnXLabelSpace = SrDataSh.Range("A175").Value '1
LnYMayorUnit = SrDataSh.Range("A176").Value '10
LnYMinimumScale = SrDataSh.Range("A177").Value '70
LnChBorder = SrDataSh.Range("A178").Value '-4142
StChFont = SrDataSh.Range("A179").Value 'Open Sans
LnChFontSize = SrDataSh.Range("A180").Value '9
In7 = SrDataSh.Range("A182").Value '151
In8 = SrDataSh.Range("A183").Value '151
In9 = SrDataSh.Range("A184").Value '151
DbChLeHeight = SrDataSh.Range("A185").Value '18
DbChLeWidth = SrDataSh.Range("A186").Value '200
DbChLeLeft = SrDataSh.Range("A187").Value '140
DbChLeTop = SrDataSh.Range("A188").Value '155
'Clears range
EmChData.Range("A1:XFD1048576").Clear
'Copy data
EmChData.Range("A1:C49").Value = SrDataSh.Range("B109:D157").Value
'Set Source data
Ch4y.Chart.SetSourceData Source:="'Sheet1'!$A$1:$C$49", PlotBy:=xlColumns
'Create reference to excel chart
Set FomtCh = ThisWorkbook.Sheets("Doc").ChartObjects(1)
With Wapp
With .Selection
'This line change position of chart that will be created to left or to right
.ParagraphFormat.LeftIndent = DbIndentCh
End With
End With
'Creates needed formating
With Ch4y
'Set size for chart
.Width = DbWidth
.Height = DbHeight
With .Chart
'Sets chart type
.ChartType = LnChType
'Sets chart legend to visible/unvisable
.HasLegend = BoLegend
'Sets chart title visible/unvisable
.HasTitle = BoTitle
'Sets color back to original for data series lines (for some reason it is not pasted in previous line)
.SeriesCollection(1).Format.Line.ForeColor.RGB = RGB(In1, In2, In3)
.SeriesCollection(2).Format.Line.ForeColor.RGB = RGB(In4, In5, In6)
'Sets line thicknes
.SeriesCollection(1).Format.Line.Weight = DbLineWeight
.SeriesCollection(2).Format.Line.Weight = DbLineWeight
'Works with x-axis
With .Axes(xlCategory)
'Sets orientation of x axis labels
.TickLabels.Orientation = DbDegrees
'Force to show all month under x-axis
.TickLabelSpacing = LnXLabelSpace
End With
'Works with y-axis
With .Axes(xlValue)
'Sets unit size for y-axis
.MajorUnit = LnYMayorUnit
'Sets value on y-axis from where values will start (Changes y=0 to value specified)
.MinimumScale = LnYMinimumScale
End With
With .ChartArea
'Sets border to none
.Border.LineStyle = LnChBorder
'Sets font
.Format.TextFrame2.TextRange.Font.Name = StChFont
'Sets font size
.Format.TextFrame2.TextRange.Font.Size = LnChFontSize
'Sets chart font color
.Font.Color = RGB(In7, In8, In9)
End With
'Checks if Legend for chart is enabled
If .HasLegend = True Then
With .Legend
'Sets height of legend
.Height = DbChLeHeight
'Sets width of legend
.Width = DbChLeWidth
'Sets distance from left side of chart
.Left = DbChLeLeft
'Sets distance from top side of chart
.Top = DbChLeTop
End With
End If
End With
End With
End Sub
I have an excel worksheet with two chart objects (pie chart and line graph). I have separate buttons to generate each graph and I want to delete the according pre-existing graph each time the generation button is pressed. Right now, I am attempting to access the Name property of the chart object to determine if the chart needs to be deleted. The deletion code looks like this:
For i = 1 To ActiveSheet.ChartObjects.Count
If ActiveSheet.ChartObjects(i).Chart.Name = "Genre" Then
ActiveSheet.ChartObjects("Genre").Delete
End If
Next i
Here is the code that generates the piechart:
Range("A2:B16").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlPie 'Exploded
ActiveChart.SetElement (msoElementChartTitleAboveChart)
ActiveChart.ChartTitle.Text = "Genre Breakdown"
ActiveChart.Parent.Name = "Genre"
Dim ChartSize As ChartObject
Set ChartSizing = Worksheets("Graphs and Stats").ChartObjects("Genre")
With ChartSizing
.Top = Range("D2").Top
.Width = Range("D2:H23").Width
.Height = Range("D2:H23").Height
.Left = Range("D2").Left
End With
Currently, the If-statement in the deletion for loop never resolves as true and I don't understand why. What is wrong with that line and/or is there better logic I could be using to check for pre-existing charts? I would prefer not use
ActiveSheet.ChartObjects.Delete
if I can avoid it to keep the generation buttons separate from each other.
EDIT: Corrected code (where worksheet name is "Graphs and Stats") using Dammer15's solution:
For i = 1 To ActiveSheet.ChartObjects.Count
If ActiveSheet.ChartObjects(i).Chart.Name = "Graphs and Stats Genre" Then
ActiveSheet.ChartObjects("Genre").Delete
End If
Next i
Set Rng = ActiveSheet.Range("A2:B16")
Set GenreChart = ActiveSheet.Shapes.AddChart
GenreChart.Name = "Genre"
With GenreChart.Chart
.SetSourceData Source:=Rng
.ChartType = xlPie
.SetElement (msoElementChartTitleAboveChart)
.ChartTitle.Text = "Genre Breakdown"
End With
You never get the correct Chart Name. Use the sheets and indexing you need but here's the general idea. You must remove the Sheet name from the accessed property.
'List of Chart Objects
Dim ChartList As ChartObjects
'The square that holds the chart
Dim MyChartFrame As ChartObject
Dim ChartToDelete As ChartObject
'The Physical chart with data
Dim MyChart As Chart
'Accessing the Objects
Set ChartList = Sheet1.ChartObjects
Set MyChartFrame = Sheet1.ChartObjects(1)
Set MyChart = MyChartFrame.Chart
Dim ChartName As String
'Remove SheetName from ChartName!!!!
ChartName = MyChart.Name
'Deleting Chart
Set ChartToDelete = Sheet1.ChartObjects(ChartName)
ChartToDelete.Delete
I have an Access 2010 application where I run a SQL query and output the results to Excel. I'm using the Excel subtotal command to create subtotals. That works fine, but on the total rows only the text ("XXX Count") is bold and the values are not bold. Our client would like the entire row bold. I've tried a couple ways without success. How do I do the entire row in the subtotals?
So here is what I currently have:
This is correct except I need all of row 5, 8, 16, and 17 bold like this:
Here is my code to create the Excel file from Access (this all works except for the bold issues):
Public Sub ExportToExcel(query)
Dim appXL As Object
Dim wbk As Object
Dim wksNew As Object
Set appXL = CreateObject("Excel.Application")
Set wbk = appXL.Workbooks.Add
Set wksNew = wbk.Worksheets("Sheet1")
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Set appXL = CreateObject("Excel.Application")
appXL.Visible = True
Set wbk = appXL.Workbooks.Add
Set wksNew = wbk.Worksheets(1)
Set cn = CurrentProject.AccessConnection
Set rs = New ADODB.Recordset
With rs
Set .ActiveConnection = cn
.Source = query
.Open
End With
With rs
'Put recordset into new wks
wksNew.Cells(2, 1).CopyFromRecordset rs
'And add headers
Dim i As Long
For i = 0 To .Fields.Count - 1
wksNew.Cells(1, i + 1).Value = .Fields(i).Name
wksNew.Cells(1, i + 1).Font.Bold = True
wksNew.Cells(1, i + 1).HorizontalAlignment = xlCenter
Next i
'Now, while the recordset is available...
'The recordset has .fields.count fields
'Subtotals are wanted from field 7 to the end
If .Fields.Count > 13 Then
ReDim ary(14 To .Fields.Count - 1)
For i = LBound(ary) To UBound(ary)
ary(i) = i
Next i
wksNew.Cells(1, 1).CurrentRegion.SubTotal GroupBy:=1, _
TotalList:=ary, Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End If
.Close
End With
End Sub
I tried this code based on this website:
Dim rCell As Range
wksNew.Columns("A:A").Select
Dim rCell As Range
For Each rCell In Selection
If Right(rCell.Value, 5) = "Count" Then
Rows(rCell.Row).Interior.ColorIndex = 36
End If
Next
but it returned a "Method or data member not found" error on the item rCell.Value.
I also tried it like this:
Dim rCell As Range
wksNew.Columns("A:A").Select
For Each rCell In Selection
If Right(rCell, 5) = "Count" Then
Selection.Font.Bold = True
End If
Next
But I got the error "ActiveX component can't create object" on the For Each line.
How do I bold the entire row for the subtotals?
You're getting an error because Access doesn't know what Selection is unless you tell it that it's connected to your Excel instance.
For Each rCell In Selection
However, don't need to select anything, or check the whole column:
Dim rCell As Range
For Each rCell In wksNew.UsedRange.Columns(1).Cells
If Right(rCell, 5) = "Count" Then
rCell.Font.Bold = True
End If
Next
Have you tried a Pivot Table?? It is easier to manage format or layout and you don't have to change too much your code because you just put your RecordSet in a PivotTableCache like the second example in this.
Rather than looping, I'd suggest collapsing the outline and formatting the visible cells:
with wksNew.Cells(1, 1).CurrentRegion
.Outlinelevel = 2
.specialcells(12).Font.Bold = True
.Outlinelevel = 3
End With
Thanks for all the suggestions. No one posted a solution that worked entirely, so here's what I ended up using:
Dim c As Object
For Each c In wksNew.Range("A1:A500")
If c.Value Like "*Total" Then
c.Offset(0, 13).Font.Bold = True
c.Offset(0, 14).Font.Bold = True
c.Offset(0, 15).Font.Bold = True
End If
Next
The only thing that concerns me is that I'm assuming this only has 500 rows. I couldn't find a way to find the number of rows and have it search only those. If I included the whole column, it took a couple minutes to complete the loop which I didn't think the client would like. Any suggestions on how to find the last row?
I would
Display level 2 of the outline, all the subtotals
Select the whole area
Use GoTo Special to select only visible cells
Apply the formatting
Change the header row formatting if it should be different
Display all the levels again (level 3)
This code demonstrates:
Sub Macro4()
Application.ScreenUpdating = False
ActiveSheet.Outline.ShowLevels RowLevels:=2
Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Font.Bold = True
'change the header row if necessary
Range(Range("A1"), Range("A1").End(xlToRight)).Font.Italic = True
ActiveSheet.Outline.ShowLevels RowLevels:=3
End Sub
I am trying to rotated my 3D Column chart. So far I have the following:
ActiveChart.Name = "44 Chart 7"
With ActiveChart
.SetSourceData Source:=pzx.Range("L126:M135")
.HasTitle = False
.HasTitle = True
.Shapes("44 Chart 7").ThreeD.RotationX = 0
.ChartTitle.Text = "Classification Actions"
.ChartArea.Font.Color = RGB(0, 0, 140)
.ChartTitle.Font.Name = "Arial"
.ChartTitle.Font.Size = 10
.Legend.Font.Size = 8
.Legend.Font.Name = "Arial"
.ChartStyle = 11
.ChartArea.Format.Line.Visible = msoFalse
End With
I have two questions -
1) what determines how a chart is named if you do not actively name the chart yourself
2) do you know why this code does not work
Here is the error I received -
Run-time error 7
Out of Memory
Thanks so much!
Naming objects have naming conventios that you must follow. For charts: when a chart is on a worksheet the Name property applies to the ChartObject object which is the container for the Chart.
With Chart
.Parent.Name = "myChartName"
End With
or
`Sheets(1).ChartObjects(3).Name = "Name of my Chart"`
or
`Sheets(1).Charts("My old Chart Name").Name = "Name of my Chart"`
If you know where your chart is residing, point to chart with sheet reference to be in the safe side than using ActiveChart. If you do not actively name the chart, then you must use chart's default original name to refer to it. Or its index.
Please try this code piece in your end.
Option Explicit
Sub createMyCharts
Dim mySheet As Worksheet
Dim mychtObject As ChartObject
Dim myChart As Chart
'-- put anything else you need to delcare and set
Set mySheet = Worksheets(1) '-- set according to your sheet
'-- delete any old leftovers to clean up
For Each mychtObject In mySheet.ChartObjects
mychtObject.Delete
Next
'-- create new chart
Set myChart = mySheet.ChartObjects.Add(Left:=30, Width:=500, Top:=30, Height:=200).Chart
With myChart
.ChartType = Excel.XlChartType.xl3DColumn '-- the full chart Type
.SetSourceData(mySheet.Range("L126", "M135"), Excel.XlRowCol.xlColumns)
.Rotation = 30
End With
'-- do anything else you need to do
End Sub
Reference to MSDN Chart Rotation
After trying out, you may comment and happy to help futher if you have any questions. :)