I am new to Vba, I have to draw circles which are color filled in the following way
1/4 color filled circle,
Half color filled circle,
3/4 color filled circle
I know I can draw a color-filled circle with the following code
Set shpOval = ActiveSheet.Shapes.AddShape(msoShapeOval, curCellLeft, curCellTop, 20, 20)
shpOval.Fill.ForeColor.RGB = RGB(128, 0, 0)
Above code gives me a full color filled circle, which property I have to change to get circle shapes that I have mentioned above.
Just for fun: Playing around with PIE-Shapes.
Sub DrawCircle(pieces As Integer, size As Double, position As Range, color)
If pieces < 1 Then pieces = 1
If pieces > 4 Then pieces = 4
Dim varShape() As String
ReDim shapeNames(0 To pieces - 1)
Dim i As Long
For i = 0 To pieces - 1
Dim sh As Shape
Dim x As Double, y As Double
x = position.Left + IIf(i = 1 Or i = 2, size, 0)
y = position.Top + IIf(i >= 2, size, 0)
Set sh = position.Parent.Shapes.AddShape(msoShapePieWedge, x, y, size, size)
shapeNames(i) = sh.Name
sh.Rotation = i * 90
If IsArray(color) Then
sh.Fill.ForeColor.RGB = color(i + LBound(color))
Else
sh.Fill.ForeColor.RGB = color
End If
sh.Line.Visible = False
Next i
If pieces > 1 Then
position.Parent.Shapes.Range(shapeNames).Group
End If
End Sub
Playing with it:
Sub test()
Call DrawCircle(3, 20, ActiveCell, vbRed)
Call DrawCircle(4, 10, ThisWorkbook.Sheets(1).Range("F3"), Array(vbYellow, vbYellow, vbBlue, vbYellow))
Call DrawCircle(1, 40, ActiveCell.Offset(2, 2), vbGreen)
End Sub
Create a range of values in excel from A1 to A4 as 25,50,75,100. Go to Insert and select "Doughnut" chart.
Related
I am attempting to loop a number of shapes to change color depending on whether there is a value >0 in a corresponding cell in another worksheet. Each next shape in the loop is a consecutive number but the corresponding cells are not i.e Shape 3 corresponds to F34, Shape 4 Corresponds to F46 ect. The problem is the non Consecutive Cells.
This is the Code I have at the Moment
Sub Shape_Color_Change()
Dim x As Integer
Dim y As Integer
y = Array(35 Or 46 Or 54 Or 62)
For x = 3 To 6
If Worksheets("Cell").Cells(y, 35) > 0 Then
Worksheets("Shape").Shapes(x).Fill.ForeColor.RGB = RGB(0, 51, 204)
Else
Worksheets("Shape").Shapes(x).Fill.ForeColor.RGB = RGB(102, 102, 102)
End If
Next x
End Sub
It gives me run time error 13 at the moment but I've also got error 1004 attempting different approaches. This one seems the closest to me though.
Use a proper array and loop through that. Your array should contain the pertinent cells so adjust to suit.
Sub Shape_Color_Change()
Dim x As Long
Dim y As Variant
y = Array("F34", "F46", "F54", "F62") 'zero-based
For x = 3 To 6
If Worksheets("Cell").Range(y(x - 3)) > 0 Then
Worksheets("Shape").Shapes(x).Fill.ForeColor.RGB = RGB(0, 51, 204)
Else
Worksheets("Shape").Shapes(x).Fill.ForeColor.RGB = RGB(102, 102, 102)
End If
Next x
End Sub
I have the following code which attempts to add a datalabel to a point in a combined donut/pie-chart:
For Each co In .ChartObjects
With co.Chart.FullSeriesCollection("Grøn pil").Points(2)
.HasDataLabel = True
With .DataLabel
.Position = xlLabelPositionOutsideEnd
.Format.AutoShapeType = msoShapeRectangle
.Format.Line.Visible = msoTrue
End With
End With
Next co
However, the code aborts on the line .Position = xlLabelPositionOutsideEnd with the error message "Run-time error 2147467259 (80004005)". Method 'Position' of object 'DataLabel' failed".
Looking at the chart, the label has been added, but it is still positioned inside the chart.
As you can see I've already positioned a label outside the chart for a different series, which is represented as a pie chart. While the series I am trying to add the label to is represented as a donut-chart.
Can't I have both the labels for the donut- and pie-chart on the outside? Isn't xlLabelPositionOutsideEnd a valid position for labels of a donut-chart? Or is the problem something else which eludes me?
Any help would be greatly appreciated!
I don't think it's possible to do exactly you want to do the way you want to do it! The option to place the labels outside the chart is not available on the doughnut chart options:
like they do on a pie chart:
However, you could perform a trick using a pie chart and a white circle to make it look like a doughnut by doing the following:
Sub AddCircle()
'Get chart size and position:
Dim CH01 As Chart: Set CH01 = ThisWorkbook.Sheets("Sheet1").ChartObjects("Chart1").Chart
Dim OB01 As ChartObject: Set OB01 = CH01.Parent
Dim x As Double: x = 0 'horizontal coordinate
Dim y As Double: y = 0 'vertical coordinate
Dim w As Double: w = 0 'width
Dim h As Double: h = 0 'height
x = OB01.Left
y = OB01.Top
w = OB01.Width
h = OB01.Height
'Adding the circle:
ThisWorkbook.Sheets("Sheet1").Shapes.AddShape(msoShapeOval, x + w / 2 - 20, y + h / 2 - 20, 40, 40).Name = "Circle01"
'Formatting the circle:
With ThisWorkbook.Sheets("Sheet1").Shapes("Circle01")
.LINE.Visible = msoFalse
.Fill.ForeColor.RGB = RGB(255, 255, 255)
End With
End Sub
And it works very nicely:
Had some fun "solving" this one...
Working with sinus and cosinus we can also calculate the outside position of the label. Following a VB snippet, how this can be done:
Sub Macro1()
Dim cx
Dim cy
Dim x
Dim y
Dim radius
Dim angle
Dim new_radius
Dim new_x
Dim new_y
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveSheet.ChartObjects("Chart 1").Select
cx = Selection.width / 2
cy = Selection.height / 2
For i = 1 To ActiveChart.FullSeriesCollection(1).Points.Count Step 1
ActiveChart.FullSeriesCollection(1).Points(i).DataLabel.Select
x = Selection.left + (Selection.width / 2)
y = Selection.top + (Selection.height / 2)
radius = Sqr(((x - cx) ^ 2) + ((y - cy) ^ 2))
angle = WorksheetFunction.Atan2(y - cy, x - cx)
new_radius = radius + 40
new_x = cx + (Sin(angle) * new_radius)
new_y = cy + (Cos(angle) * new_radius)
Selection.left = new_x - (Selection.width / 2)
Selection.top = new_y - (Selection.height / 2)
Next i
End Sub
I'm trying to import a picture to excel cell and I'm facing issues with re-sizing.
Steps:
Copy/Paste the picture to the cell
Re-size the picture manually
And also resize the cell to fix on the picture.
Is there any other way to do it instead of manually?
I'm not sure what exactly you meant with re size the picture manually, but might this be working for you?
Sub ResizeCells()
Dim X As Double, Y As Double, Z As Double
Dim s As Shape
For Each s In ActiveSheet.Shapes
If s.Type = msoPicture Then
For X = s.TopLeftCell.Column To s.BottomRightCell.Column
Y = Y + ActiveSheet.Cells(1, X).ColumnWidth
Next X
For X = s.TopLeftCell.Row To s.BottomRightCell.Row
Z = Z + ActiveSheet.Cells(1, X).RowHeight
Next X
s.TopLeftCell.ColumnWidth = Y
s.TopLeftCell.RowHeight = Z
End If
Next s
End Sub
Note:
Max RowHeight is 409
Max ColumnWidth is 255
This goes the other way.
We will insert a Shape from the Internet.
We will move it to cell B1.
We will resize the Shape (both height and width) to fit in B1First place this link in cell A1:
http://www.dogbreedinfo.com/images26/PugPurebredDogFawnBlackMax8YearsOld1.jpg
Then run:
Sub MAIN()
Call InstallPicture
Call PlaceAndSizeShape
End Sub
Sub InstallPicture()
Dim v As String
v = Cells(1, 1).Value
With ActiveSheet.Pictures
.Insert (v)
End With
End Sub
Sub PlaceAndSizeShape()
Dim s As Shape, B1 As Range, w As Double, h As Double
Set s = ActiveSheet.Shapes(1)
s.Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Set B1 = Range("B1")
s.Top = B1.Top
s.Left = B1.Left
s.Height = B1.Height
s.Width = B1.Width
End Sub
This post is old, but nobody mentioned resizing the picture to match the cell.
Excel is very unreliable when I tired to scale the width using #Andrew's code. Luckily, rCell.Left is in the correct units. You can get the actual column width using:
rCell.Offset(0, 1).Left - rCell.Left
This Code will Resize the Cell to Your Picture
Sub ResizePictureCells()
For Each Picture In ActiveSheet.DrawingObjects
PictureTop = Picture.Top
PictureLeft = Picture.Left
PictureHeight = Picture.Height
PictureWidth = Picture.Width
For N = 2 To 256
If Columns(N).Left > PictureLeft Then
PictureColumn = N - 1
Exit For
End If
Next N
For N = 2 To 65536
If Rows(N).Top > PictureTop Then
PictureRow = N - 1
Exit For
End If
Next N
Rows(PictureRow).RowHeight = PictureHeight
Columns(PictureColumn).ColumnWidth = PictureWidth * (54.29 / 288)
Picture.Top = Cells(PictureRow, PictureColumn).Top
Picture.Left = Cells(PictureRow, PictureColumn).Left
Next Picture
End Sub
I have a column/bar chart and I'd want to color it red and grey this way: first column red, second grey, third red, fourth grey and so on until there's no more values. I'm struggling with the macro recorder because it specifies every point but the idea is that data will be updated and will change the number of points/values to less or more depending on the situation.
You need to write a code that loops through the number of series/points in your chart. The code below loops through each series and/or points in a selected chart and formats every second bar with the same fill color.
Sub ColorBarsInChart()
Dim i As Integer
Dim j As Integer
'Exit if no chart is selected
If Not (TypeName(Selection) = "ChartArea" Or TypeName(Selection) = "PlotArea") Then Exit Sub
'If only one series in chart
If ActiveChart.SeriesCollection.Count = 1 Then
For j = 1 To ActiveChart.SeriesCollection(1).Points.Count
If j Mod 2 Then
ActiveChart.SeriesCollection(1).Points(j).Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
Else
ActiveChart.SeriesCollection(1).Points(j).Format.Fill.ForeColor.RGB = RGB(127, 127, 127)
End If
Next j
'If more than one series in chart
Else
For i = 1 To ActiveChart.SeriesCollection.Count
For j = 1 To ActiveChart.SeriesCollection(i).Points.Count
If i Mod 2 Then
ActiveChart.SeriesCollection(i).Points(j).Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
Else
ActiveChart.SeriesCollection(i).Points(j).Format.Fill.ForeColor.RGB = RGB(127, 127, 127)
End If
Next j
Next i
End If
End Sub
Since I don't know if your specific chart consists of multiple data series, I have made the code versatile enough to work in both cases.
I have a little problem with my owc chartspace, I would like to draw a chart like in the picture but my problem is that it draws only for one series I would like to draw it for the 1 the 2 and the 3 I don't know how to do this.
I have a listbox and a combobox, I select from the list box the 1,2,3 and I select from the combobx y or z such that x is fixed.
Then I put the data in plage(1) for x and plage(2) for y but the problem is that it works only for the first item I select from the listbox ( in this picture the "1" )
Could you tell what is wrong in my code?
the vba code for drawing the chart into the userform is:
Private Sub drow()
Dim i, k As Integer, x As Integer
Dim j As Integer
Dim Table(), Plage(2)
Dim id As Integer
id = 1
Do While ComboBox.Value <> idi(id, 1)
id = id + 1
Loop
For i = Cht.SeriesCollection.Count To 1 Step -1
Cht.SeriesCollection.Delete i - 1
Next i
k = 1
ReDim Table(ListBox.ListCount)
For i = 0 To ListBox.ListCount - 1
If ListBox.Selected(i) = True Then
Table(k) = ListBox.List(i)
k = k + 1
End If
Next i
With Cht
.HasLegend = True
.Legend.Position = chLegendPositionBottom
.HasTitle = True
.Title.Caption = ComboBox.Text
End With
Cht.Type = C.chChartTypeColumnClustered3D
With Cht
'first serie
.SeriesCollection.Add
.SeriesCollection(0).Caption = sheet.Cells(2, 15 + id)
.SeriesCollection(0).DataLabelsCollection.Add
.SeriesCollection(0).DataLabelsCollection(0).Position = chLabelPositionCenter
.SeriesCollection(0).DataLabelsCollection(0).Font.Color = RGB(255, 255, 255)
.SeriesCollection.Add
.SeriesCollection(1).Caption = sheet.Cells(2, 20) .SeriesCollection(1).DataLabelsCollection.Add
.SeriesCollection(1).DataLabelsCollection(0).Position = chLabelPositionCenter
.SeriesCollection(1).DataLabelsCollection(0).Font.Color = RGB(255, 255, 255)
.SetData C1.chDimCategories, C1.chDataLiteral, Table
End With
For j = 0 To ListBox.ListCount - 1
If ListBox.Selected(j) = True Then
Plage(1) = sheet.Cells(j + 3, 15 + id) 'the Xs
Plage(2) = sheet.Cells(j + 3, 20) 'Les 'the Ys
With Cht
.SeriesCollection(0).SetData C1.chDimValues, C1.chDataLiteral, Plage(1)
.SeriesCollection(1).SetData C1.chDimValues, C1.chDataLiteral, Plage(2)
End With
Erase Plage
End If
Next j
End Sub
I am very new to the whole owc and VB thing and I am having some troubles myself, but have you tried using C1.chDimXValues and C1.chDimYValues instead of the chDimValues in the below statement:
.SeriesCollection(0).SetData
C1.chDimValues, C1.chDataLiteral,
Plage(1) .SeriesCollection(1).SetData
C1.chDimValues, C1.chDataLiteral,
Plage(2)
Sorry if this might sound trivial, I can see your coding skills are much more advanced than mine. Good luck!