I have a line (=autoshape) drawing object on an Excel spreadsheet. I want to determine which cell it "points" to. For this I need to know the coordinates of the start and end points.
I can use .Top, .Left, .Width, .Height to determine bounding rectangle, but the line may be in 2 different positions in that rectangle.
To do this you must use the members HorizontalFlip and VerticalFlip. The following function should do what you want:
Function CellFromArrow(ByVal s As Shape) As Range
Dim hFlip As Integer
Dim vFlip As Integer
hFlip = s.HorizontalFlip
vFlip = s.VerticalFlip
Select Case CStr(hFlip) & CStr(vFlip)
Case "00"
Set CellFromArrow = s.BottomRightCell
Case "0-1"
Set CellFromArrow = Cells(s.TopLeftCell.Row, s.BottomRightCell.Column)
Case "-10"
Set CellFromArrow = Cells(s.BottomRightCell.Row, s.TopLeftCell.Column)
Case "-1-1"
Set CellFromArrow = s.TopLeftCell
End Select
End Function
This code is tested in Excel 2010. Seems to work. Hope this helps!
EDIT:
If you have to worry about shapes contained in groups, then it seems the only solution is to ungroup, iterate through the shapes and then regroup. Something like the following:
Dim s As Shape
For Each s In ActiveSheet.Shapes
If s.Type = msoGroup Then
Dim oldName as String
Dim sGroup As GroupShapes
Dim GroupMember as Shape
Set sGroup = s.GroupItems
oldName = s.Name 'To preserve the group Name
s.Ungroup
For Each GroupMember in sGroup
'DO STUFF
Next
Set s = sGroup.Range(1).Regroup 'We only need to select one shape
s.Name = oldName 'Rename it to what it used to be
End If
Next
You can refer to ShapeRange Documentation for more info on the Regroup method.
Let me know if this works for you!
Related
I'm looking for a way to have three different colors in the same line chart of a diagram in Excel, depending on the values themselves or where they are from (from which sheet f.e).
Till now, I have the following code:
Sub ChangeColor()
Dim i As Integer
Dim IntRow As Integer
Dim r As Range
ActiveSheet.ChartObjects("Cash").Activate
ActiveChart.SeriesCollection(1).Select
IntRow = ActiveChart.ChartObjects("Cash").Count
For i = 2 To IntRow
Set r = Cells(2, i)
If r.Value < 3000 Then
Selection.Border.ColorIndex = 5
Else
Selection.Border.ColorIndex = 9
End If
Next
End Sub
However, the if statement is not considered and the color of the whole line changes only whenever I change the first ColorIndex. I have no idea, how to color parts of the line depending on the values in the underlying table.
Moreover, by defining IntRow as ActiveChart.ChartObjects("Cash").Count I'm not able to get the length of my array. This problem can be solved by manual counting and declaring IntRow as an Integer, however, the version above seems nicer (if that is possible of course).
I appreciate any help! Thank you.
Alexandra
You can read the values directly from the chart series:
Sub ChangeColor()
Dim cht As Chart, p As Point, s As Series
Dim i As Integer
Dim numPts As Long
'access the chart directly - no select/activate required
Set cht = ActiveSheet.ChartObjects("Cash").Chart
'reference the first series
Set s = cht.SeriesCollection(1)
'how many points in the first series?
numPts = s.Points.Count
'loop over the series points
For i = 1 To numPts
Set p = cht.SeriesCollection(1).Points(i)
p.Border.ColorIndex = IIf(s.Values(i) < 3000, 5, 9)
Next
End Sub
I want to ask for a letter color in an If conditional:
string="asdfghjkl"
for i=1 to len(string)
letter = mid(string, i, 1)
input_letter = inputbox("Write a letter")
if letter = input_letter 'and letter.Font.Color = RGB(31,78,120)
'my code here
endif
next
The and letter.Font.Color = RGB(31,78,120) is not working. It says i need an object.
Is there any similar way to ask this? This RGB color is blue, and I am using this code to transform the entire sentence to blue (with the record macro excel setting)
With Selection.Font
.ThemeColor = xlThemeColorAccent1
.TintAndShade = -0.499984740745262
End With
Thanks
Regarding your question's problem:
The .Font.Color is a property of the class Range, but in your line of code:
if letter = input_letter 'and letter.Font.Color = RGB(31,78,120)
... you're trying to access this property in the variable letter, which is a String (you don't explicitly declare it as such, but it gets automatically declared when you execute letter = mid(string, i, 1) just above).
That is why you get an Object required exception: you're trying to access the property .Font.Color on something that is not a Range object (actually, not an Object at all).
Regarding your real need:
I'm not sure to understand what you're trying to do. Are you trying to reach a multi-colored text into a single cell in Excel? If I've got it right, you'll have a string:
string="asdfghjkl"
(please note: you can't call your variable String, that's a reserved keyword for the code. Think of calling it something else, though I guess you already do that in your real code or you wouldn't be able to execute it at all).
... and, for each letter of that string,
for i=1 to len(string)
... you want the user to give you a color. In that case, you can't do it in Excel. If not that, could you please express better your real need?
The code below comes closest to your OP logic and comment using the .Characters property of a cell Range (B11) containing your string value:
Code
Option Explicit
Sub test()
Dim blue As Long: blue = RGB(31, 78, 120)
Dim s As String: s = "asdfgh"
Dim letter As String
Dim input_letter As String
Dim i As Integer
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("MySheet").Range("B11")
With rng
.Value = s
' color whole string
.Characters(1, Len(s)).Font.Color = blue
For i = 1 To Len(s)
letter = Mid(s, i, 1)
input_letter = InputBox("Write a letter")
If letter = input_letter And .Characters(i, 1).Font.Color = blue Then
'color found character
.Characters(i, 1).Font.Color = vbWhite
ElseIf input_letter = "" Then Exit For
End If
Next
End With
End Sub
Notes
Always use Option Explicitin your modules declaration head. So you would see that String isn't allowed as variable name as it's a function.
The extra color check in the If condition seems redundant, as characters so long a r e blue.
You seem to prefer repeated InputBoxes within the For - Next loop, could be reduced to a single call.
Recently, in an interview I encountered a question in VBA. The question is:
Write a program to sort the shapes in a worksheet, like for example : I have various shapes like circle, triangle, rectangle, pentagon... This needs to be sorted and placed one below the other.
I tried with Shapes object and msoshapeRectangle method. But it didnt work.
Could you please tell me is this possible to be done?
Thanks
It was an interesting challenge, so I did it. Might as well post the result (commented for clarity):
Sub tgr()
'There are 184 total AutoShapeTypes
'See here for full list
'https://msdn.microsoft.com/VBA/Office-Shared-VBA/articles/msoautoshapetype-enumeration-office
Dim aShapeTypes(1 To 184) As String
Dim ws As Worksheet
Dim Shp As Shape
Dim i As Long, j As Long
Dim vShpName As Variant
Dim dLeftAlign As Double
Dim dTopAlign As Double
Dim dVerticalInterval As Double
Dim dHorizontalInterval As Double
Dim dPadding As Double
Set ws = ActiveWorkbook.ActiveSheet
'Sort order will be by the AutoShapeType numerical ID
'Using this, shapes will be sorted in this order (incomplete list for brevity):
' Rectangle, Parallelogram, Trapezoid, Diamond, Rounded rectangle, Octagon, Isosceles triangle, Right triangle, Oval, Hexagon
'Note that you can use a Select Case to order shapes to a more customized list
'I use this method to put the -2 (indicates a combination of the other states) at the bottom of the sort order
For Each Shp In ws.Shapes
Select Case Shp.AutoShapeType
Case -2: aShapeTypes(UBound(aShapeTypes)) = aShapeTypes(UBound(aShapeTypes)) & "||" & Shp.Name
Case Else: aShapeTypes(Shp.AutoShapeType) = aShapeTypes(Shp.AutoShapeType) & "||" & Shp.Name
End Select
Next Shp
'Now that all shapes have been collected and put into their sort order, perform the actual sort operation
'Adjust the alignment and vertical veriables as desired
'The Padding variable is so that the shapes don't start at the very edge of the sheet (can bet set to 0 if that's fine)
'I have it currently set to sort the shapes vertically, but they can be sorted horizontally by uncommenting those lines and commenting out the vertical sort lines
dPadding = 10
dLeftAlign = 5
dTopAlign = 5
dVerticalInterval = 40
dHorizontalInterval = 40
j = 0
For i = LBound(aShapeTypes) To UBound(aShapeTypes)
If Len(aShapeTypes(i)) > 0 Then
For Each vShpName In Split(Mid(aShapeTypes(i), 3), "||")
With ws.Shapes(vShpName)
'Vertical Sort
.Left = dLeftAlign
.Top = j * dVerticalInterval + dPadding
'Horizont Sort
'.Top = dTopAlign
'.Left = j * dHorizontalInterval + dPadding
End With
j = j + 1
Next vShpName
End If
Next i
End Sub
I have a PowerPoint slide with 5 shapes on it. I would like to do different things with theses shapes in a macro. How can I change one of these shapes by using the shape ID? For example, I have two shapes with a name of "Title 1" but I want to use the one with an ID of 15.
Here is my code:
Sub size_n_spread_v()
Dim j As Integer
Dim sld As Slide
Dim SldId As Long
gap = std_gap
SldId = ActiveWindow.View.Slide.SlideIndex
Set sld = ActivePresentation.Slides(SldId)
Call SortMultArray
new_dim = (total_dim - gap * (lngRow - 1)) / lngRow
'This works but is not specific:
'sld.Shapes.("Title 1").Height = new_dim
'This would hopefully be specific but the syntax does not work Please HELP!
'sld.Shapes.("Title 1").Id(15).Height = new_dim
End Sub
Does someone know the right syntax to change the shape via ID?
I don't know of a way, but you could write a simple helper function that you could then use throughout your project to make things easier on yourself. Something like this would work:
Public Function GetShapeById(s As Slide, n As String, id As Long) As Shape
Dim objShape As Shape
For Each objShape In s.Shapes
If StrComp(objShape.Name, n, vbTextCompare) = 0 And objShape.Id = id Then
Set GetShapeById = objShape
Exit Function
End If
Next
End Function
Then you could use it like so:
Sub size_n_spread_v()
....
' Instead of:
sld.Shapes.("Title 1").Id(15).Height = new_dim
' Use:
GetShapeById(sld, "Title 1", 15).Height = new_dim
End Sub
The function mentioned above is the only way to get a shape by Id. You have to search through the Shapes collection as there is no equivalent ShapeIndex as there is for SlideIndex. The other solution to find a specific shape is to uniquely identify shapes by adding your own Tag but this is a more complex solution.
Hi there!
I am trying to color a graph (a task tracker) via VBA, in excel. The idea is to color all "categories" a certain color -- visually, it would mean making all bars on each "row" a particular color. I'm using the following code, which I copied from http://peltiertech.com/vba-conditional-formatting-of-charts-by-category-label/:
Sub ColorByCategoryLabel()
Dim rPatterns As Range
Dim iCategory As Long
Dim vCategories As Variant
Dim rCategory As Range
Set rPatterns = ActiveSheet.Range("A1:A5")
With ActiveChart.SeriesCollection(2)
vCategories = .XValues
For iCategory = 1 To UBound(vCategories)
Set rCategory = rPatterns.Find(What:=vCategories(iCategory))
.Points(iCategory).Format.Fill.ForeColor.RGB = rCategory.Interior.Color
Next
End With
End Sub
and I can't figure out what is wrong.
Basically, I have a series (series2), with horizontal (category) axis labels consisting of integers from 1-5. This category determines the vertical position of the bar, but I also want to color each bar in this series according to this vertical position, according to the color in the range(a1:a5) -- which is exactly what this code seems to be doing.
Any suggestions, as to the code, or perhaps, any alternative way to color bar graphs based on the value of the "horizontal (category) axis"?
Thanks!
Well, I found an answer to my problem by stepping through it. I can't imagine this to be the easiest way to horizontal bar graphs according to their height but it works.
Sub ColorByCategoryLabel()
Dim iCategory As Long
Dim vCategories As Variant
Dim rCategory As Range
Dim CurColor As Double
Dim CurColorIndex As Long
Dim CurHeight As Double
CurHeight = 0
CurColorIndex = 1
CurColor = ActiveSheet.Cells(CurColorIndex + 1, 10).Interior.Color
ActiveSheet.ChartObjects("Chart 1").Select
With ActiveChart.SeriesCollection(2)
vCategories = .XValues
For iCategory = 1 To UBound(vCategories)
If .Points(iCategory).Top > CurHeight Then
CurColorIndex = CurColorIndex + 1
CurColor = ActiveSheet.Cells(CurColorIndex + 1, 10).Interior.Color
CurHeight = .Points(iCategory).Top
End If
.Points(iCategory).Format.Fill.ForeColor.RGB = CurColor
Next
End With
End Sub
You would need to modify the line
Curcolor = ActiveSheet.Cells(CurColorIndex+1,10).Interior.Color
To properly specify the cells whose background color you wish to copy.
By the way, if anyone is interested in the timetracker, it is hosted here: https://drive.google.com/file/d/0B85fvjQDbl3lUVpPNmdGT1VkWW8/view?usp=sharing