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
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"
After 2 days trying to find a solution to my problem, I need your help please.
I'm working on powerpoint VBA script, and I've got a Table (3,3). In the row 1, I've already input some string in cells.
I want to know why my script doesn't want to write NOK in cells when the string does'nt match "comp" for example
Here is my VBA script:
Public Sub CreateTable1()
' déclaration of variables
Dim objSld As Slide
Dim objShp As Shape
Dim foundText1 As Object
Dim FindWhat As String
Dim I As Integer
Dim j As Integer
Set objSld = ActivePresentation.Slides(1)
Set objShp = objSld.Shapes.AddTable(3, 3, 15, 150, 700, 500)
' Give a name to table
objShp.Name = "Table1"
' Define size of cells
With objSld.Shapes("Table1").Table
.Columns(1).Width = 115
.Columns(2).Width = 115
.Columns(3).Width = 115
.Rows(1).Height = 120
.Rows(2).Height = 120
.Rows(3).Height = 120
'Write in cells
With .Cell(1, 1).Shape.TextFrame
.TextRange.Text = "Composition"
End With
With .Cell(2, 1).Shape.TextFrame
.TextRange.Text = "Material"
End With
With .Cell(3, 1).Shape.TextFrame
.TextRange.Text = "Method"
End With
' Define text position
For I = 1 To 3
For j = 1 To 3
With .Cell(j, I).Shape.TextFrame
.VerticalAnchor = msoAnchorMiddle
.HorizontalAnchor = msoAnchorCenter
.TextRange.Font.Size = 18
End With
Next j
Next I
'Command find
'Browse row 1 from line 1 to 3
For x = 1 To 3
Set foundText1 = objSld.Shapes("Table1").Table.Cell(x, 1).Shape.TextFrame.TextRange.Find(FindWhat:="Comp")
If foundText1 = "Comp" Then
'MsgBox foundText1 & x
'Will write in cell (x,2) OK and x
objSld.Shapes("Table1").Table.Cell(x, 2).Shape.TextFrame.TextRange.Text = "OK " & x
Else
'Will write in cell (x,2) NOK and x
'Doesn't works !! Why??
objSld.Shapes("Table1").Table.Cell(x, 2).Shape.TextFrame.TextRange.Text = "NOK " & x
End If
Next x
End With
End Sub
I Would like to know if you see where is the mistake. The function Else seems not working..
I found the solution !!
For those who're lost with this same problem, here is my code:
Public Sub CreateTable1()
' déclaration of variables
Dim objSld As Slide
Dim objShp As Shape
Dim foundText1 As Object
Dim TextRng As TextRange
Dim FindWhat As String
Dim I As Integer
Dim j As Integer
Set objSld = ActivePresentation.Slides(8)
Set objShp = objSld.Shapes.AddTable(3, 3, 15, 150, 700, 500)
' Give a name to table
objShp.Name = "Table1"
' Define size of cells
With objSld.Shapes("Table1").Table
.Columns(1).Width = 115
.Columns(2).Width = 115
.Columns(3).Width = 115
.Rows(1).Height = 120
.Rows(2).Height = 120
.Rows(3).Height = 120
'Write in cells
With .Cell(1, 1).Shape.TextFrame
.TextRange.Text = "Composition"
End With
With .Cell(2, 1).Shape.TextFrame
.TextRange.Text = "Material"
End With
With .Cell(3, 1).Shape.TextFrame
.TextRange.Text = "Method"
End With
' Define text position
For I = 1 To 3
For j = 1 To 3
With .Cell(j, I).Shape.TextFrame
.VerticalAnchor = msoAnchorMiddle
.HorizontalAnchor = msoAnchorCenter
.TextRange.Font.Size = 18
End With
Next j
Next I
'Command find
'Browse row 1 from line 1 to 3
End With
End Sub
Creation of a second sub to understand where does script failed
Sub yolo()
Dim objSld As Slide
Dim oTbl As Table
Dim lRow As Long
Dim lCol As Long
Dim foundText1 As Object
Set objSld = ActivePresentation.Slides(8)
Set oTbl = objSld.Shapes("Table1").Table
With oTbl
For lRow = 1 To .Rows.Count
With .Cell(lRow, 1).Shape
'Do something with each cell's text
'Does this shape has text?
If .HasTextFrame Then
Set TextRng = oTbl.Cell(lRow, 1).Shape.TextFrame.TextRange
Set foundText1 = TextRng.Find(FindWhat:="Comp")
Do While Not (foundText1 Is Nothing)
With foundText1
oTbl.Cell(lRow, 2).Shape.TextFrame.TextRange.Text = "OK"
Set foundText1 = TextRng.Find(FindWhat:="Comp", After:=.Start + .Length - 1)
End With
Loop
End If
End With
Next lRow
End With
End Sub
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 have been working on this code where I need to take input of images from my PC, paste them in a certain column, and then resize the cells according to the image size. Following is the code, I am using:
Sub BBS()
Dim file As Variant
Dim r As Integer
Dim ID As Integer
For r = 1 To 6
ID = Cells(r, 1).Value
file = "D:\" & ID & ".jpg"
If Dir(file) = "" Then
Else
With ActiveSheet.Pictures.Insert(file)
.Left = ActiveSheet.Cells(r, 5).Left
.Top = ActiveSheet.Cells(r, 5).Top
End With
End If
Next r
Call Resize
End Sub
Sub Resize()
Worksheets("Sheet1").Columns("A:I").AutoFit
Worksheets("Sheet1").Rows("1:10").AutoFit
End Sub
The images are getting pasted, but I'm not able to adjust the cell size.
That's because the picture is not in the cell - it has merely been placed in the worksheet at the position of the cell.
Try in in Excel itself (not the VBA window). You are essentially inserting a picture, moving it so that it matches up with the top-left coordinates of a cell, and then trying to AutoFit. (Nothing will happen to the cell).
You can 'fudge' it by setting the size of your pictures using this:
Sub BBS()
Dim file As Variant
Dim r As Integer
Dim ID As Integer
For r = 1 To 6
ID = Cells(r, 1).Value
file = "D:\" & ID & ".jpg"
If Not Dir(file) = "" Then
With ActiveSheet.
.AddPicture file, msoFalse, msoTrue, _
ActiveSheet.Cells(r, 5).Left, ActiveSheet.Cells(r, 5).Top, 100, 100
End With
End If
Next r
Call Resize
End Sub
Sub Resize()
Worksheets("Sheet1").Columns("A:I").ColumnWidth = 18.29
Worksheets("Sheet1").Rows("1:10").RowHeight = 100
End Sub
Note that the scales used by .AddPicture and ColumnWidth / RowHeight are not the same. You'll have to experiment here.
Updated
Sub BBS()
Dim r As Integer
Dim ID As Integer
Dim ws As Worksheet
Dim objShell As New Shell
Dim objFolder As Folder
Dim objFile As ShellFolderItem
Dim strDimensions As String
Dim intPos As Integer 'Position of first space in strDimensions
Dim intWidth As Integer
Dim intHeight As Integer
Dim intWidthMax As Integer
Set objFolder = objShell.Namespace("D:\")
Set ws = ActiveSheet
intWidthMax = 0
For r = 1 To 3
ID = Cells(r, 1).Value
Set objFile = objFolder.ParseName(ID & ".jpg")
strDimensions = objFile.ExtendedProperty("Dimensions")
intPos = InStr(1, strDimensions, " ", vbTextCompare)
'These next variables contain the dimensions of the image in pixels.
intWidth = CInt(Mid(strDimensions, 2, intPos - 2))
intHeight = CInt(Mid(strDimensions, intPos + 3, Len(strDimensions) - intPos - 3))
With ActiveSheet.Shapes
'Here we treat the dimension values (which are actually in pixels) as points.
'The conversions depend on your DPI, so you could play around with a scaling
'factor here.
.AddPicture objFile.Path, msoFalse, msoTrue, ActiveSheet.Cells(r, 5).Left, _
ActiveSheet.Cells(r, 5).Top, intWidth, intHeight
End With
'RowHeight is done in points, so it will match the height of your images.
ws.Rows(r).RowHeight = intHeight
If intWidth > intWidthMax Then intWidthMax = intWidth
Next r
'Set column width to widest image width.
'Width points are different from height points.
'5.29 as a conversion works for me (and my DPI).
ws.Columns(5).ColumnWidth = intWidthMax / 5.29
End Sub
I'm writing a code to populate a data table then take and save an image of it by calling a module someone else made. My portion of the code is able to create the image and the sub that gets called works for creating images for other tables, but I think something is missing in my portion. This is the for loop to cycle through different product lines and create images of their tables.
For i = 0 To UBound(allLines)
Cells(bcell, 2) = Cells(product, 2)
Cells(bcell, 3) = Cells(product, 3)
Cells(bcell, 4) = Cells(product, 4)
Cells(bcell, 5) = Cells(product, 5)
Cells(ecell, 2) = Cells(product, 6)
Cells(ecell, 3) = Cells(product, 7)
Cells(ecell, 4) = Cells(product, 8)
Cells(ecell, 5) = Cells(product, 10)
Range(Cells(acell, 1), Cells(ecell, 5)).Select
Selection.Copy
Range("M14").Select
ActiveSheet.Pictures.Paste.Select
myfilename = Year(Now) & " " & MonthName(Month(Now)) & " " & allLines(i) & " Production Status Metrics" ' & ".jpg"
EndFilePath = "C:\Users\*******\Documents\**********\TEST FILES\" & myfilename 'edited for privacy
Call ExportMyPicture(allLines(i), EndFilePath) 'Module: Export_Cells_to_File
Range("A1").Select
acell = acell + 5
ecell = ecell + 5
bcell = bcell + 5
product = product + 1
Next
This is the sub that gets called up to the line that gives me an error
Sub ExportMyPicture(SelectedLine As String, EndFilePath As String)
Dim MyChart As String, MyPicture As String
Dim PicWidth As Long, PicHeight As Long
Application.ScreenUpdating = False
MyPicture = Selection.Name
With Selection
PicHeight = .ShapeRange.Height
PicWidth = .ShapeRange.Width
End With
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=SelectedLine & " Actions" 'This line gives the error
The error message reads object variable or with block variable not set
It seems that you are trying to make an embedded chart. In this case the chart has a container object called a chart object which sits between the chart and the containing sheet. Rather than creating a chart and then adjusting its location, you can add it as a chart object in the target sheet. Something like:
Sub test()
Dim mySheet As Worksheet
Set mySheet = Sheets(1)
Dim PicWidth As Long, PicHeight As Long
PicWidth = 200
PicHeight = 100
Dim CO As ChartObject
Dim CH As Chart
Set CO = mySheet.ChartObjects.Add(10, 10, PicWidth, PicHeight)
Set CH = CO.Chart
CH.ChartType = xlXYScatter
CO.Activate
End Sub
The 4 parameters of the Add method are left, top. width, height.