Determining if AutoShapes overlap/occlude in Excel and moving vertically to resolve - vba

I am using some VBA code to create an autoshape and a text box, group them, and move to a vertical and horizontal position based on cell positions.
The code will look at user input to create and group the shape & textbox, and will usually create over 100 shapes, many of which will overlap. Currently, the groups are placed with reference to the top of a row; I want to separate them so that they don't overlap.
I would like to be able to determine if a group overlaps another group, and if so, to move it down 25pts. Given that this check would need to then determine if the new position also overlaps, it's becoming a bit too complicated for my skill level (self-taught beginner.)
I have researched this extensively, and I've come across the following VBA code:
Application.ScreenUpdating = False
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim sh As Worksheet
Set sh = wb.ActiveSheet
Dim s1 As Shape
Dim s2 As Shape Dim CheckOverlap As Boolean
For i = 1 To 10 'sh.Shapes.Count
If i <= sh.Shapes.Count Then
Set s1 = sh.Shapes(i)
CheckOverlap = False
For Each s2 In Worksheets("Plan").Shapes
If s2.Left < (s1.Left + s1.Width) And s2.Top < (s1.Top + s1.Height) Then
CheckOverlap = True
Exit For
End If
Next
If CheckOverlap = True Then
s2.Top = s2.Top + 30
End If
End If
Next
End Sub
I found the basis of the code here:
Hit-Testing and Resolving Occlusion of AutoShapes in Excel
However, I haven't been able to figure it out how to make it check whether overlap occurs vertically as well as horizontally, as well as the multiple-overlap problem. Currently, if I execute that code, it just moves every shape down even irrespective of whether it overlaps.
If someone could help me out I would really appreciate it! This is the hardest part of my project and I'd love to find a solution.
Many thanks for your help

Try the below code. This should align all the charts on the active sheet vertically 25 points apart
Sub MoveShapes()
Dim IncrementTop, TopPosition, LeftPosition, i as Long
IncrementTop = 0
LeftPosition = 'place the desired starting left position here
TopPosition = 'place the desired starting top position here
For i = 1 To ActiveSheet.Shapes.Count
ActiveSheet.Shapes(i).Left = LeftPosition
ActiveSheet.Shapes(i).Top = TopPosition + IncrementTop
IncrementTop = IncrementTop + 25
Next i
End Sub

Found an answer:
Sub MoveShapes1()
Application.ScreenUpdating = False
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim sh As Worksheet
Set sh = wb.ActiveSheet
Dim s1 As Shape
Dim s2 As Shape
Dim CheckOverlap As Boolean
For i = 1 To sh.Shapes.Count
If i <= sh.Shapes.Count Then
Set s1 = sh.Shapes(i)
Search:
CheckOverlap = False
For Each s2 In Worksheets("Plan").Shapes
If s2.ID = s1.ID Then GoTo Suit
If s2.Left <= (s1.Left + s1.Width) And s2.Left >= s1.Left _
And s2.Top <= (s1.Top + s1.Height) And s2.Top >= s1.Top Then
s1.Top = s1.Top + 32
CheckOverlap = True
Exit For
End If
Suit:
Next
If CheckOverlap = True Then GoTo Search
End If
Next
Application.ScreenUpdating = True
End Sub

Related

Excel VBA - color data labels ("value from cells") according to the font of the source

I have to run many bar charts in excel 2016, each one showing the company performance over the seasons, for a certain country. On top of each bar I'd like to see the %Change in this format [Color10]0%"▲";[Red] -0%"▼". Reason why I added the data labels, and I used the function "value from cells" to show the %Change instead of the amount sold. Now everything is in place, and my percentages are nicely placed on top of the bars, but no way I can color them automatically (positive green and negative red). I tried formatting the labels directly from the format window placed under "numbers", but I discovered it doesn't work at all when the label content is derived using "value from cells".
So I started looking into VBA, but since I'm pretty ignorant about programming, I didn't succeed. I'm looking for a code that changes the data labels of my chart so that they maintain the font of the source (in the source my %Change values are already in the desired format ([Color10]0%"▲";[Red] -0%"▼"). Googling I found different solutions but none worked. I'll post the ones I that look better to me.
Sub legend_color()
Dim SRS As Series
With ActiveChart
For Each SRS In .SeriesCollection
SRS.ApplyDataLabels AutoText:=True, LegendKey:= _False,
ShowSeriesName:=False,
ShowCategoryName:=False,
ShowValue:=True, _ ShowPercentage:=False,
ShowBubbleSize:=False
SRS.DataLabels.Font.ColorIndex = SRS.Border.ColorIndex
Next SRS
End With
End Sub
This one was the only one that actually run, and colored my labels all white. With the following I run into errors.
Sub color_labels()
Dim chartIterator As Integer,
pointIterator As Integer, _seriesArray() As Variant
For chartIterator = 1 To ActiveSheet.ChartObjects.Count
seriesArray=ActiveWorkbook.Sheets("Sheet1").ChartObjects(chartIterator). _Chart.SeriesCollection(1).Values For pointIterator = 1 To UBound(seriesArray)
If seriesArray(pointIterator) >= 0 Then
ActiveWorkbook.Sheets("Sheet1").ChartObjects(chartIterator). _
Chart.SeriesCollection(1).Points(pointIterator).Interior.Color = _RGB(146, 208, 80)
Else
ActiveWorkbook.Sheets("Sheet1").ChartObjects(chartIterator). _Chart.SeriesCollection(1).Points(pointIterator).Interior.Color = _RGB(255, 0, 0)
End If
Next pointIterator
Next chartIterator
End Sub
Sub ArrowColour()
Dim ncars As Integer
ncars = Range("A1").Value
With ActiveSheet.Shapes.Range(Array("Down Arrow 1")).Fill
If ncars > 0 Then
.ForeColor.RGB = RGB(0, 176, 80)
Else
.ForeColor.RGB = RGB(255, 0, 0)
End If
End With
End Sub
Option Explicit
Sub ApplyCustomLabels()
Dim rLabels As Range
Dim rCell As Range
Dim oSeries As Series
Dim Cnt As Integer
Set rLabels = Range("C2:C" & Cells(Rows.Count, "C").End(xlUp).Row)
Set oSeries = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)
oSeries.HasDataLabels = True
Cnt = 1
For Each rCell In rLabels
With oSeries.Points(Cnt).DataLabel.Text = rCell.Value.Font.Color =rCell.Font.Color
End With
Cnt = Cnt + 1
Next rCell
End Sub
Thank you very much in advance for all of your help,
Tommaso
If you're just missing the colors then you can format each label using something like:
Sub Tester()
Dim s As Series, dl As DataLabels, d As DataLabel
Dim i As Long, rngLabels
Set s = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)
Set dl = s.DataLabels
'Option 1: set label color based on label value
For i = 1 To dl.Count
With dl(i)
.Font.Color = IIf(Val(.Text) < 0, vbRed, vbGreen)
End With
Next i
'Option 2: set label color based on label source cell
' Note use of DisplayFormat to pick up custom
' formatting colors
Set rngLabels = Range("C7:C13")'<< source range for data labels
For i = 1 To dl.Count
dl(i).Font.Color = rngLabels(i).DisplayFormat.Font.Color
Next i
End Sub

Setting a VBA form object using a string

Hello,
I am trying to set up a form which is a calendar from which the user can select a date (by default the current month appears). The form consists of 42 command buttons (I have left the default name ie. CommandButton1) which I am setting the day number.
At the moment I have a long-winded section of code for each button (I used Excel to generate this rather than type it all out) which locks and hides the button if it is outside of the month in question which looks like this:
NewDate.CommandButton1.Caption = Format(DATlngFirstMonth - DATintDayNumFirst + DATintX, "dd")
If DATintX < DATintDayNumFirst Then
With NewDate.CommandButton1
.Locked = True
.Visible = DATbooShowExtraDays
.ForeColor = RGB(150, 150, 150)
End With
Else
With NewDate.CommandButton1
.Locked = False
.Visible = True
.ForeColor = RGB(0, 0, 0)
End With
End If
I know that I can refer to a command button by:
Dim objCommandButton As Object
Set objCommandButton = NewDate.CommandButton1
..which neatens the code up somewhat. But what I would like to do is refer to the command button as a string so I can loop through all 42, ie.
Dim n as integer
n = 1
Do Until n > 42
Set objCommandButton = NewDate.CommandButton & n
'Some operations
n = n + 1
Loop
Many thanks in advance for assistance.
You can loop through all controls of the form. Try
Sub LoopButtons()
Dim it As Object
For Each it In NewDate.Controls
Debug.Print it.Name
Next it
End Sub
Then you can put conditional expression (if ... then) in place of Debug.Print or whatever. For example
If Instr(it.Name, "CommandButton") Then
'do your code
end if
Here's code which iterates over ActiveX controls on active sheet:
Sub IterateOverActiveXControlsByName()
Dim x As Integer
Dim oleObjs As OLEObjects
Dim ctrl As MSForms.CommandButton
Set oleObjs = ActiveSheet.OLEObjects
For x = 1 To 10
Set ctrl = oleObjs("CommandButton" & x).Object
Next
End Sub

Excel VBA, choosing chart color based on series value comparison

I have some code I have used to color excel charts with for quite a few years and it has worked well, (although there are likely better ways to do it). The charts contain 2 series, the first series with a value and the second with a goal. The goal does not get colored but the vba loops through the first series and colors according to hard coded goals in the vba.
The problem I have now is that I have added a chart that has a goal that can change month to month so having the hard coding doesn't work. How can I use the same theory but compare series 1 data directly to series 2 data to determine the color, (Case Is series 1 point > series 2 point, etc). I have tried a number of ways without success so any assistance would be greatly appreciated. below is the code for the proven technique.
Private Sub Worksheet_Activate()
Dim cht As Object
Dim p As Object
Dim V As Variant
Dim Counter As Integer
For Each cht In ActiveSheet.ChartObjects
Counter = 0
V = cht.Chart.SeriesCollection(1).Values
For Each p In cht.Chart.SeriesCollection(1).Points
Counter = Counter + 1
Select Case V(Counter)
'Case Is = 1
'p.Shadow = False
'p.InvertIfNegative = False
'p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, _
' Degree:=0.78
'p.Fill.Visible = True
'p.Fill.ForeColor.SchemeColor = 5
Case Is < 0.98
p.Shadow = False
p.InvertIfNegative = False
p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, _
Degree:=0.78
p.Fill.Visible = True
p.Fill.ForeColor.SchemeColor = 3
'Case Is < 0.98
'p.Shadow = False
'p.InvertIfNegative = False
'p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=4, _
' Degree:=0.38
'p.Fill.Visible = True
'p.Fill.ForeColor.SchemeColor = 6
Case Is <= 1
p.Shadow = False
p.InvertIfNegative = False
p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, _
Degree:=0.78
p.Fill.Visible = True
p.Fill.ForeColor.SchemeColor = 10
End Select
Next
Next
End Sub
Did you try something like:
Case Is > .SeriesCollection(2).Values()(Counter)
Also revised to get rid of some apparent redundancy (if need a loop and a counter variable, e.g., when looping several collections/arrays in parallel), it seems better IMO to just loop by index, rather than For Each _object_ with a separate counter.
Private Sub Worksheet_Activate()
Dim cht As Object
Dim p As Object
Dim V As Variant
Dim Counter As Integer
For Each cht In ActiveSheet.ChartObjects
Counter = 0
With cht.Chart
V = .SeriesCollection(1).Values
For Counter = 1 to.SeriesCollection(1).Points.Count
'Assign your Point object, if needed elsewhere
Set p = .SeriesCollection(1).Points(Counter)
Select Case V(Counter)
Case Is > .SeriesCollection(2).Values()(Counter)
'DO STUFF HERE.
'Add other cases if needed...
End Select
Next
End With
Next
End Sub
And unless you need the values in an array V for some other reason, this can be further reduced:
Private Sub Worksheet_Activate()
Dim cht As Object
Dim p As Object
Dim val1, val2
Dim Counter As Integer
For Each cht In ActiveSheet.ChartObjects
Counter = 0
With cht.Chart
For Counter = 1 to.SeriesCollection(1).Points.Count
'Assign your Point object, if needed elsewhere
Set p = .SeriesCollection(1).Points(Counter)
' extract specific point value to variables:
val1 = .SeriesCollection(1).Values()(Counter)
val2 = .SeriesCollection(2).Values()(Counter)
Select Case V(Counter)
Case val1 > val2
'DO STUFF HERE.
'Add other cases if needed...
End Select
Next
End With
Next
End Sub
Edited with final code, The gradient needed 2 refreshes to completely fill in, (I would have to hit another tab and then go back), so I added a loop to run the code through twice and now it updates perfect the first time. Hopefully this helps others. This allows for a completely dynamic chart. Again, thank you David.
Private Sub Worksheet_Activate()
Dim cht As Object
Dim p As Object
Dim V As Variant
Dim Counter As Integer
Dim L As Integer
For L = 1 To 2
For Each cht In ActiveSheet.ChartObjects
Counter = 0
With cht.Chart
V = cht.Chart.SeriesCollection(1).Values
For Counter = 1 To .SeriesCollection(1).Points.Count
Set p = .SeriesCollection(1).Points(Counter)
Select Case V(Counter)
'Blue Gradient
'Case Is = .SeriesCollection(2).Values()(Counter)
'p.Shadow = False
'p.InvertIfNegative = False
'p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, _
' Degree:=0.78
'p.Fill.Visible = True
'p.Fill.ForeColor.SchemeColor = 5
'Red Gradient
Case Is < .SeriesCollection(2).Values()(Counter)
p.Shadow = False
p.InvertIfNegative = False
p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, _
Degree:=0.78
p.Fill.Visible = True
p.Fill.ForeColor.SchemeColor = 3
'Yellow Gradient
'Case Is < .SeriesCollection(2).Values()(Counter)
'p.Shadow = False
'p.InvertIfNegative = False
'p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=4, _
' Degree:=0.38
'p.Fill.Visible = True
'p.Fill.ForeColor.SchemeColor = 6
'Green Gradient
Case Is >= .SeriesCollection(2).Values()(Counter)
p.Shadow = False
p.InvertIfNegative = False
p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, _
Degree:=0.78
p.Fill.Visible = True
p.Fill.ForeColor.SchemeColor = 10
End Select
Next
End With
Next
Next L
End Sub

Excel: How to retrieve the frozen range of the Worksheet programmatically?

I'm using VSTO to build an Excel add-in.
I want to build two functions. The first one, stores the frozen range at my Excel.Range variable called RNG and then unfreeze panes, using the following command.
Globals.ThisAddIn.Application.ActiveWindow.FreezePanes = False
The second function selects the range and freezes it again. With the following
RNG.Select()
Globals.ThisAddIn.Application.ActiveWindow.FreezePanes = True
What i don't know is how to store the frozen range before unfreeze the window.
Does someone can help me with doing this, or knows some other workaround?
Thanks.
With #Byron 's help, I solved my problem. Here is my code!
'Flag that indicates if there is a "frozen" scenario stored in the other variables
Private frozen_scenario As Boolean
'Range that marks the first cell of the frozen header
Private range_freeze_begin As Excel.Range
'Range that marks the the first cell not contained by the frozen header
Private range_freeze_end As Excel.Range
'Range that marks the the first visible cell (in the not fixed pane)
Private first_visible_cell_not_fixed As Excel.Range
'Unfreezes the panes, saving the current scenario
Private Sub unfreezeLines()
With Globals.ThisAddIn.Application.ActiveWindow
If .FreezePanes Then
Dim frozen_pane_limit_line As Integer
Dim frozen_pane_limit_column As Integer
frozen_pane_limit_line = .Panes(1).VisibleRange.Rows.Count + 1
frozen_pane_limit_column = .Panes(1).VisibleRange.Columns.Count + 1
If .Panes.Count = 2 Then
If .Panes(1).VisibleRange(1, 1).Row = .Panes(2).VisibleRange(1, 1).Row Then
frozen_pane_limit_line = 1
Else
frozen_pane_limit_column = 1
End If
Me.first_visible_cell_not_fixed = .Panes(2).VisibleRange(1, 1)
Else '4 panes
Me.first_visible_cell_not_fixed = .Panes(4).VisibleRange(1, 1)
End If
Me.range_freeze_begin = .Panes(1).VisibleRange(1, 1)
Me.range_freeze_end = Me.sheet.Cells(frozen_pane_limit_line, frozen_pane_limit_column)
Me.frozen_scenario = True
.FreezePanes = False
End If
End With
End Sub
'Recovers the frozen state, exactly like it was when the first function was called
Private Sub recuperaLinhasCongeladas()
If Me.frozen_scenario Then
'Creating the frozen header again
Globals.ThisAddIn.Application.Goto(Me.range_freeze_begin, True)
Me.range_freeze_end.Select()
Globals.ThisAddIn.Application.ActiveWindow.FreezePanes = True
'Showing the same cell at the top
Globals.ThisAddIn.Application.Goto(Me.first_visible_cell_not_fixed, True)
Me.frozen_scenario = False
End If
End Sub

Different errors like statement out of block, variable error showing in my macro

I am new to coding. I was trying to make a macro which searches through the charts in a sheet , searches if the chart has any data of Pfizer and then changing them in the chart to blue. So here, I am trying to search if datalabel has Pfizer and then changing the text to blue.
I tried using this code but did not work:-
Public Sub chartFormatting()
Dim CTRYname As String
Dim p As Integer
ivalue As String
Dim l As Integer
Dim rownum As Integer
For p = 1 To 13
CTRYname = ThisWorkbook.Sheets("Country lookup").Range("A1").Offset(p, 0).Value
rownum = wkbCurr.Sheets(CTRYname).Range("AA25").End(xlDown).Row
For s = 1 To rownum
ivalue = wkbCurr.Sheets(CTRYname).Charts(1).SeriesCollection(1).Points(s).DataLabel.Text
If InStr(ivalue, "Pfizer") <> 0 Then
With ivalue
With .Font
.Color = -65536
.TintAndShade = 0
End With
End With
wkbCurr.Sheets(CTRYname).Charts(1).SeriesCollection(1).Points(s).DataLabel.Text = ivalue
End If
Next s
Next p
End Sub
The variables have been declared else where too.
Now it is showing me a lot of errors. Please help and suggest a better way of formatting the text and lines in charts.
My main challenge is to format them only if Pfizer is there.
The root of your issue here is navigating the Chart object hierarchy. I find a good way to figure it out is the use the macro recorder to record the action you want to code (colour a label in this case) abd examine to objects recorded. You just need to ignore all the Select malarkey thae the recorder does and get to the core of the objects recorded.
I used this technique to refactor your code. I also use intermediate objects(sh, chrt and dl in this case) to help break down the object model:
Public Sub chartFormatting()
Dim CTRYname As String
Dim p As Integer
Dim ivalue As String
Dim l As Integer
Dim rownum As Integer
Dim s As Long
Dim dl As DataLabel
Dim chrt As Chart
Dim sh As Worksheet
For p = 1 To 13
CTRYname = ThisWorkbook.Sheets("Country lookup").Range("A1").Offset(p, 0).Value
Set sh = wkbCurr.Worksheets(CTRYname)
rownum = sh.Range("AA25").End(xlDown).Row
Set chrt = sh.ChartObjects(1).Chart
For s = 1 To rownum
With sh.ChartObjects(1).Chart.SeriesCollection(1).Points(s).DataLabel
If InStr(.Text, "Pfizer") <> 0 Then
With .Format.TextFrame2.TextRange.Font.Fill.ForeColor
.SchemeColor = 4
.TintAndShade = 0
End With
End If
End With
Next s
Next p
End Sub