VBA: need to sort shapes - vba

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

Related

VBA Excel: Different colors in one line diagram depending on value

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

Selecting a Cell by it's position (Left,Top)

I'm creating a sales channel map and use the .Left/.Top w/ + (.5*.width/.Height) to get the center of the images I'm connecting. I'd like to also use this method to select the cell that corresponds to this coordinate.
The only solution I can think of (and could implement, but I'd rather avoid an iterative approach) would be something like:
Sub FindCellLoc(DesiredYLocation,DesiredXLocation)
'Finds the Column Number of the X coordinate
RunningTotalX = 0
For X = 1 to 100000000
RunningTotalX = RunningTotalX + Cells(1,X).width
if RunningTotalX >= DesiredXLocation then
TargetCol = Cells(1,X).Column
Goto FoundCol
End if
Next X
FoundCol:
'Finds the Column Number of the X coordinate
RunningTotalY = 0
For Y = 1 to 100000000
RunningTotalY = RunningTotalY + Cells(Y,1).width
if RunningTotalY >= DesiredYLocation then
TargetRow = Cells(Y,0).Column
Goto FoundRow
End if
Next Y
FoundRow
Cells(TargetRow,TargetCol).Select
End Sub
I'd really appreciate any input about a non-iterative approach.
Thanks,
-E
Here is a routine to select a cell based on the x and y position:
Public Sub SelectCellByPos(x, y)
With ActiveSheet.Shapes.AddLine(x, y, x, y)
.TopLeftCell.Select
.Delete
End With
End Sub
I assume you have access to the shape object from which you got the desired locations. If so, you could do something like
Function GetCenterCell(shp As Shape) As Range
Dim lRow As Long, lCol As Long
lRow = (shp.TopLeftCell.Row + shp.BottomRightCell.Row) \ 2
lCol = (shp.TopLeftCell.Column + shp.BottomRightCell.Column) \ 2
Set GetCenterCell = shp.Parent.Cells(lRow, lCol)
End Function
Sub test()
Dim shp As Shape
Set shp = Sheet1.Shapes(1)
Debug.Print GetCenterCell(shp).Address
End Sub
That won't give you the exact middle if there isn't an exact middle. It will skew top and left as the integer division truncates (I think). But using the TopLeftCell and BottomLeftCell properties will be far superior to iterating, even if it means you're iterating through the cells in that range or some other implementation.

How do I determine end points of a Line drawing object?

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!

Conditionally Coloring a Graph in Excel

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

get cell color in VBA and copy it into a pie-chart

Could somebody possibly tell me a simple and straightforward way to read the colour of a cell in a worksheet into VBA and then to use this RGB code or what ever to colour a part of a pie chart?
I'm trying
Function rgb_color(cl As Range) As String
Dim rgbc As Long, rc As Long, gc As Long, bc As Long
If cl.Cells.Count = 1 Then
rc = cl.Interior.Color Mod 256
rgbc = Int(cl.Interior.Color / 256)
gc = rgbc Mod 256
bc = Int(rgbc / 256)
Else
End If
End Function
Sub ColorScheme(cht As Chart, i As Long)
Dim Colors
Select Case i Mod 10
Case 0
rgb_color (C2)
rgb_color (C3)
rgb_color (C4)
So the first part is the function that gets the RGB code from the cell and I have a variety of charts to color which is the reason I chose different case statements. I know that I could manually do the RGB colours if needed but is there a simple way to use the different rc,bc,gc variables for each of the three cells (C2 to C4) as RGB values? It would look like an array
RGB(rc of C2; gc of C2; bc of C2)
same for C3 and C4
then the next case with the same procedure?
''######################################################
EDIT from Tim's comment
If I got Tim (comment below) correct I could write
Sub ColorScheme(cht As Chart, i As Long)
Dim Colors
Select Case i Mod 10
Case 0
ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1).Points(x).Format.Fill.For‌eColor.RGB = Range("A1").Interior.Color
could somebody potentially correct me if that's wrong?
This shows exactly how to do it (or at least how I would do it). It's up to you to make it work.
Sub Tester()
Dim cht As Chart, x As Long
Set cht = ActiveSheet.ChartObjects(1).Chart
For x = 0 To 1
'set pie chart source data
SetColorScheme cht, x 'this will apply the color scheme
cht.CopyPicture
'...paste to point in other chart
Next x
End Sub
'set the color scheme on the passed chart object
Sub SetColorScheme(cht As Chart, i As Long)
Dim y_off As Long, rngColors As Range
Dim x As Long
y_off = i Mod 10
'this is the range of cells which has the colors you want to apply
Set rngColors = ThisWorkbook.Sheets("colors").Range("A1:C1").Offset(y_off, 0)
With cht.SeriesCollection(1)
'loop though the points and apply the corresponding fill color from the cell
For x = 1 To .Points.Count
.Points(x).Format.Fill.ForeColor.RGB = _
rngColors.Cells(x).Interior.Color
Next x
End With
End Sub