Challenge: Triangle Area Select tool

[Aussiebear]

Lateral???? what's that when you are upside down as in Australia?

[xluser2007]

In haste, I'm gone 'til Monday or Tuesday.
Yes, start with Selection.columns(1).select. But with all this swine flu about I wouldn't want to be anywhere near these cells.
Possibly, with the likes of Selection.areas(1).select, but haven't time to test/refine.
I am away for a few days, but if where I'm going has an internet connection and... I'll give it a go.
ps contiguous

LOL .

Sure thing p45cal. Again appreciate your help and insights. I reckon md's

Selection.Columns(1).Select

approach will solve the above queries.

In terms of consolidating the code, please take your time. I know you must be very busy.

Thanks and kind regards,

[xluser2007]

Are you looking to exactly create the pattern shown in Post #9

md, sorry I;m not sure I understand what you mean by this query. Could you please clarify.

[mdmackillop]

I would love to understand how to consolidate the macros into a single code.

If you need to select multiple shape areas, you could do this in one code. Otherwise, you need to call separate macros for each shape. I wondered whether your demo sheet was a Standard layout you used.

[xluser2007]

If you need to select multiple shape areas, you could do this in one code. Otherwise, you need to call separate macros for each shape. I wondered whether your demo sheet was a Standard layout you used.

Hi md,

At any one point, this macro should only select one shape area i.e. the bottom left traingle for example. The consolidation idea was basically to make a generic macro to select triangles and another generic macro to select diaginals, and then have 6 separate macros to call on that these 2 generic macros for the 6 types of selections.

The Demo sheet, just showed every single possible combination. The ideal outcome would be to create a docked commandbar with pictures of the triangles with the relavent code linked to it (that i was hoping to ask in another thread - once this is fully resolved). The user would click the relevant shape button to select that type of shape.

Does that clarify more malcolm? Please let me know if I am being unclear in any way.

thanks and kind regards

[mdmackillop]

Here's a simple userform incorporating p45cal's code. You can add images etc. as required.

[xluser2007]

Hi md,

You are a real trooper. Thank you for preparing this.

I have however, based on your approach a few changes that I would like to make.

1. From your code, I noticed that the code will not run if a single row is selected. I am thinking of adding an extended functionality whereby it will work if a single row is selected. For example, I have attached a picture where the user selects only one row and runs the "triangle bottom-right" select macro.

Please note that if the user selects a mutiple row block then the preeference should always go to the first column i.e.

Selection.Columns(1).Select

However, if the user selects a 1 row * m column array then the code should select a triangle as shown in the target output picture below. The code would be simlar for the other triangle tools. Note that when selecting a single rows of cells, then the bottom-left and bottom-right triangles selected would be on top of the row selected (as shown). Where as the top-left triangle and the top right-triangle would be below the row selected. As such this may require some error handling to ensure that the triangle selected does not exceed Excel's rows and column limits.

But I am confused as to how to do the above, as the code is a bit complicated.

Is it possible to extend the code to do this?

I hope this makes sense. Please let me know if I can clarify further.

[xluser2007]

Also, my second query is:

2. I would like to make this collection of macros more as a dockable toolbar rather than a userform. I have taken the liberty of making my target images for my ideal add-in. I am unsure as to how to make an add-in that loads these images with suitable error-handling. Could you please help me with this?

Al the images are created in the attached spreadsheet, I just need help compiling and attaching them to a toolbar and the relevant macros.

Please find attached the spreadsheet with the macros.

I found the following example by Ole Erlandsen to do this with custom images, but wasn't sure how to integrate it with the existing code:

http://www.erlandsendata.no/download...ndbaricons.zip

This is from the website:

http://www.erlandsendata.no/english/index.php?d=endownloadcommandbars

I really appreciate your great help md, if you could please help to solve these queries, this would be a brilliant addin indeed .

[mdmackillop]

Here's my revised code (I follow it easier). I'll have a look at the buttons
[VBA]
Option Explicit
Dim x As Long, y As Long, z As Long
Dim rngTriang As Range, r As Range, cls As Long

Function Rng(Sel As Range, Direct As Long) As Range
x = 0: y = 0: z = 0
cls = Sel.Cells.Count
If Sel.Rows.Count > 1 Then
Set Rng = Sel.Columns(1)
Else
If Direct = -1 Then
Set Rng = Sel.Cells(1, 1).Offset(1 - cls).Resize(cls)
Else
Set Rng = Sel.Cells(1, 1).Resize(cls)
End If
End If
End Function
Sub TopLeft()
Set r = Rng(Selection, 1)
x = r.Cells.Count
Set r = r.Cells(1, 1)
Set rngTriang = r

For z = x To 1 Step -1
Set rngTriang = Union(rngTriang, r.Offset(y).Resize(, z))
rngTriang.Interior.ColorIndex = 6
y = y + 1
Next
rngTriang.Interior.ColorIndex = 1
r.Offset(x - 1).Activate
Set rngTriang = Nothing
End Sub

Sub BotLeft()
Set r = Rng(Selection, -1)
x = r.Cells.Count
Set r = r.Cells(1, 1)
Set rngTriang = r

For z = 1 To x
Set rngTriang = Union(rngTriang, r.Offset(y).Resize(, z))
y = y + 1
Next
rngTriang.Interior.ColorIndex = 22
r.Offset(x - 1).Activate
Set rngTriang = Nothing
End Sub

Sub BotRight()
Set r = Rng(Selection, -1)
x = r.Cells.Count
Set r = r.Cells(1, 1)
Set rngTriang = r.Offset(x - 1)


For z = x To 1 Step -1
Set rngTriang = Union(rngTriang, r.Offset(z - 1, y).Resize(, z))
y = y + 1
Next
rngTriang.Interior.ColorIndex = 3
r.Offset(x - 1).Activate
Set rngTriang = Nothing
End Sub

Sub TopRight()
Set r = Rng(Selection, 1)
x = r.Cells.Count
Set r = r.Cells(1, 1)
Set rngTriang = r

For z = x To 1 Step -1
Set rngTriang = Union(rngTriang, r.Offset(y, x - z).Resize(, z))
y = y + 1
Next
rngTriang.Interior.ColorIndex = 4
r.Offset(x - 1).Activate
Set rngTriang = Nothing
End Sub

Sub DiagBLTR()
Set r = Rng(Selection, 1)
x = r.Cells.Count
Set r = r.Cells(1, 1)
Set rngTriang = r.Offset(, x - 1)

For z = x To 1 Step -1
Set rngTriang = Union(rngTriang, r.Offset(y, z - 1))
y = y + 1
Next
rngTriang.Interior.ColorIndex = 14
r.Offset(x - 1).Activate
Set rngTriang = Nothing
End Sub

Sub DiagTLBR()
Set r = Rng(Selection, 1)
x = r.Cells.Count
Set r = r.Cells(1, 1)
Set rngTriang = r

For z = 1 To x
Set rngTriang = Union(rngTriang, r.Offset(y, z - 1))
y = y + 1
Next
rngTriang.Interior.ColorIndex = 16
r.Activate
Set rngTriang = Nothing
End Sub


[/VBA]

[mdmackillop]

Try this

[xluser2007]

Try this

Hi md,

Just to reiterate, you are a very helpful and great coder!

I have installed and tested your code.I have a few changes/ queries that i wanted to run by you.

In terms of the actual code, the final output is supposed to be a selection tool and not highlighting. as such, I went through and changed your code as follows (in this case for the "TopLeft" macro):

From:

[vba]Sub TopLeft()
Set r = Rng(Selection, 1)
x = r.Cells.Count
Set r = r.Cells(1, 1)
Set rngTriang = r

For z = x To 1 Step -1
Set rngTriang = Union(rngTriang, r.Offset(y).Resize(, z))
rngTriang.Interior.ColorIndex = 6
y = y + 1
Next
rngTriang.Interior.ColorIndex = 1
r.Select
Set rngTriang = Nothing
End Sub[/vba]
to:

[vba]Sub TopLeft()
Set r = Rng(Selection, 1)
x = r.Cells.Count
Set r = r.Cells(1, 1)
Set rngTriang = r

For z = x To 1 Step -1
Set rngTriang = Union(rngTriang, r.Offset(y).Resize(, z))
y = y + 1
Next

rngTriang.Select
r.Activate

Set rngTriang = Nothing

End Sub[/vba]
Do you agree that these are th only changes I need to make with regards to making it a selection only tool?

2. For the Top Left macro, so as to make the activecell on the bottom left of the triangle what would I change the following lines to?
[vba]
Set r = Rng(Selection, 1)
x = r.Cells.Count
Set r = r.Cells(1, 1)[/vba]
3. I find that the addin-toolbar doesn't always load when I open and Close Excel. To make it work, I need to keep Going to Tools>Addins and then unchecking the Triangle Addin, and then re-checking it to make the toolbar appear. Is there a way to make the toolbar appear every time you open an instance of excel and then having it remain docked whilst the instance of Excel remains open?

4. In terms of error handling, I found that If I highlighted a single-row of cells, say H2:K2 and selected the bottom right triangle select macro, the macro threw a "Run-time error '1004' Application defined object error. Presumably, this is becasue it is trying to bulid a triangle of height 4, but can't actually select it, as there are not enough rows to go up. As such is there a way to ensure that the selections remain below Excel's row and column limits? In this example, the ideal output would be selecting the array fo cells {H2,I2,K2,I1,J1}.

5. In terms of more generic error handling, I thought it would be nice to have a check that there is actually something selected before ruunign the macro. and secondly that the object selected is in fact a range object. as such, I wrote the following code. Could you please let me know if it is
(a) Redundant in any way and;
(b) if it can be improved in any way and;
(c) How to most rigorously integrate it with all of the 6 macros?

[vba]Sub Check_Selection_is_Range()

If Not Selection Is Nothing Then

If UCase(TypeName(Selection)) <> "RANGE" Then

Call MsgBox("You have currently selected a ." _
& vbCrLf & "" _
& vbCrLf & "Please select a COLUMN or a ROW of CELLS and re-run to continue." _
, vbCritical, "This tool only works on Selected Cells!")

Else

' Do the relevant SELECTION macro here

End If

Else

Call MsgBox("Please select a COLUMN or a ROW of CELLS and re-run to continue.", _
vbExclamation, "This tool only works on Selected Cells!")


End If


End Sub[/vba]
Sorry for the barrage of questions, but I figure you are the best person to ask these queries.

That's all I had for now based on the initial testing, sincerely appreciate your help on this md .

Kind regards,

[mdmackillop]

Please post your suggestions for error checking code. I can look at these this evening for incorporation.

[Bob Phillips]

In terms of the actual code, the final output is supposed to be a selection tool and not highlighting. as such, I went through and changed your code as follows (in this case for the "TopLeft" macro):

From:

[vba]Sub TopLeft()
Set r = Rng(Selection, 1)
x = r.Cells.Count
Set r = r.Cells(1, 1)
Set rngTriang = r

For z = x To 1 Step -1
Set rngTriang = Union(rngTriang, r.Offset(y).Resize(, z))
rngTriang.Interior.ColorIndex = 6
y = y + 1
Next
rngTriang.Interior.ColorIndex = 1
r.Select
Set rngTriang = Nothing
End Sub[/vba]
to:

[vba]Sub TopLeft()
Set r = Rng(Selection, 1)
x = r.Cells.Count
Set r = r.Cells(1, 1)
Set rngTriang = r

For z = x To 1 Step -1
Set rngTriang = Union(rngTriang, r.Offset(y).Resize(, z))
y = y + 1
Next

rngTriang.Select
r.Activate

Set rngTriang = Nothing

End Sub[/vba]
Do you agree that these are th only changes I need to make with regards to making it a selection only tool?

You would need to make changes to all of the routine, BotLeft, BotRight, etc., as well.

2. For the Top Left macro, so as to make the activecell on the bottom left of the triangle what would I change the following lines to?
[vba]
Set r = Rng(Selection, 1)
x = r.Cells.Count
Set r = r.Cells(1, 1)[/vba]

That should be

[vba]
Set r = Rng(Selection, 1)
x = r.Cells.Count
Set r = r.Cells(x, 1)[/vba]

3. I find that the addin-toolbar doesn't always load when I open and Close Excel. To make it work, I need to keep Going to Tools>Addins and then unchecking the Triangle Addin, and then re-checking it to make the toolbar appear. Is there a way to make the toolbar appear every time you open an instance of excel and then having it remain docked whilst the instance of Excel remains open?

Try moving the toolbar build code to Workbook_Open.

4. In terms of error handling, I found that If I highlighted a single-row of cells, say H2:K2 and selected the bottom right triangle select macro, the macro threw a "Run-time error '1004' Application defined object error. Presumably, this is becasue it is trying to bulid a triangle of height 4, but can't actually select it, as there are not enough rows to go up. As such is there a way to ensure that the selections remain below Excel's row and column limits? In this example, the ideal output would be selecting the array fo cells {H2,I2,K2,I1,J1}.

[vba]
Function Rng(Sel As Range, Direct As Long) As Range
x = 0: y = 0: z = 0
cls = Sel.Cells.Count
If Sel.Rows.Count > 1 Then
Set Rng = Sel.Columns(1)
Else
If Direct = -1 Then
If Sel.Cells(1, 1).Row - cls < 1 Then cls = Sel.Cells(1, 1).Row
Set Rng = Sel.Cells(1, 1).Offset(1 - cls).Resize(cls)
Else
Set Rng = Sel.Cells(1, 1).Resize(cls)
End If
End If
End Function[/vba]

[xluser2007]

Hi Bob, md,

Many thanks for your helpful replies.

You would need to make changes to all of the routine, BotLeft, BotRight, etc., as well.

Thanks, I have updated all the routines accordingly.

That should be

[vba]
Set r = Rng(Selection, 1)
x = r.Cells.Count
Set r = r.Cells(x, 1)[/vba]

Bob, I find that this doesn't quite work, as changing r (the active cell value that we want the selection to end up with as the Activecell) actually affects the Union Selection.

Is there an alternative way to do this, using say the "rngTriang" range?

Try moving the toolbar build code to Workbook_Open.

This sounds promising, as I believe you mean similar to johnske's ALZ creation Article here. I can;t find the zip file though. I was hoping to just take johnske's generic Addin code and add in md's great modules to it. Have you got this file per chance, or any ideas how to integrate using his rigorous addin error-handling code?

[vba]
Function Rng(Sel As Range, Direct As Long) As Range
x = 0: y = 0: z = 0
cls = Sel.Cells.Count
If Sel.Rows.Count > 1 Then
Set Rng = Sel.Columns(1)
Else
If Direct = -1 Then
If Sel.Cells(1, 1).Row - cls < 1 Then cls = Sel.Cells(1, 1).Row
Set Rng = Sel.Cells(1, 1).Offset(1 - cls).Resize(cls)
Else
Set Rng = Sel.Cells(1, 1).Resize(cls)
End If
End If
End Function[/vba]

I just tested this. I find that it doesn;t throw any more errors, which is fantatstic. Minor point, but in the example I gave, it highlights {H2,I2,I1}, instead of {H2,I2,K2,I1,J1}. Not a major issue, but just wondering if it's possible to do the second option. Also, the code throws a similar error if you hit the rows down the bottom of the worksheet i.e. after row 65536 (unlikely that anyone would ever run it down there though .

Also, sincerely sorry to bother, but the top-left routine for example throws a similar error if you exceed the column bounds (I only gave the row example). Is there any way to amend for this case?

Please post your suggestions for error checking code. I can look at these this evening for incorporation.

md, the only error handling that I could come up with was the "Check_Selection_is_Range" macro to ensure that a proper range is selected, which I was hoping to understand how to integrate with the 6 macros from you.

As such, Bob has almost answered the other error-handling queries regarding row/column limits and the active cell postion etc.

The only other thing pending is integrating with Johnske's Addin code.

Could you please assist with the above. this is helping heaps, not just for my work purpose, but learning how MVPs approach tool development.

Sincere thanks to both of you, I am learning lots, at least from a testing and debugging front.

kind regards,

[Bob Phillips]

Bob, I find that this doesn't quite work, as changing r (the active cell value that we want the selection to end up with as the Activecell) actually affects the Union Selection.

Is there an alternative way to do this, using say the "rngTriang" range?

This doesn't change the r range so it shouldn't affect the union, but just uses row x in the activate rather that row 1 as you had it.

This sounds promising, as I believe you mean similar to johnske's ALZ creation Article here. I can;t find the zip file though. I was hoping to just take johnske's generic Addin code and add in md's great modules to it. Have you got this file per chance, or any ideas how to integrate using his rigorous addin error-handling code?

I am not sure and I don't think I have the patience to read all 11 pages of that article, but MD's addin was already fully functional, just making that change should ensure that the toolbar is always setup. The other changes re for the function changes that you require.

I am also not sure that you mean error handling, or at least error catching. It seems to me that you want it to behave differently if there is no room to behave normally, which is a different thing. In that case, it needs to be coded accordingly.

I just tested this. I find that it doesn;t throw any more errors, which is fantatstic. Minor point, but in the example I gave, it highlights {H2,I2,I1}, instead of {H2,I2,K2,I1,J1}. Not a major issue, but just wondering if it's possible to do the second option. Also, the code throws a similar error if you hit the rows down the bottom of the worksheet i.e. after row 65536 (unlikely that anyone would ever run it down there though .

It is possible, but it would mean recutting MDs code as he works horizontally using a row count, and my code adjusted that count.

[Bob Phillips]

How about this?

[vba]

Option Explicit

Public Enum TriangulateStyle
TopLeft = 1
TopRight = 2
BottomRight = 3
BottomLeft = 4
DiagonalBLTR = 5
DiagonalTLBT = 6
End Enum

Public Function TriangulateTL()
Dim rng As Range

Set rng = Selectiont
Call TriangulateNext(TopLeft, rng, rng.Cells.Count, 0)
rng.Select
rng.Cells(rng.Areas(1).Rows.Count, 1).Activate
End Function

Public Function TriangulateTR()
Dim rng As Range

Set rng = Selection
Call TriangulateNext(TopRight, rng, rng.Cells.Count, 0)
rng.Select
rng.Cells(rng.Areas(1).Rows.Count, 1).Activate
End Function

Public Function TriangulateBR()
Dim rng As Range

Set rng = Selection
Call TriangulateNext(BottomRight, rng, rng.Cells.Count, 0)
rng.Select
rng.Cells(rng.Areas(1).Rows.Count, 1).Activate
End Function

Public Function TriangulateBL()
Dim rng As Range

Set rng = Selection
Call TriangulateNext(BottomLeft, rng, rng.Cells.Count, 0)
rng.Select
rng.Cells(1, 1).Activate
End Function

Private Function TriangulateNext( _
ByRef Direction As TriangulateStyle, _
ByRef rng As Range, _
ByRef NumCells As Long, _
ByRef Addon As Long)

NumCells = NumCells - 1
Addon = Addon + 1
Select Case Direction

Case TopLeft
If NumCells > 0 And rng.Areas(1).Column + Addon <= Columns.Count Then

Set rng = Union(rng, rng.Areas(1).Offset(0, Addon).Resize(NumCells))
Call TriangulateNext(Direction, rng, NumCells, Addon)
End If

Case TopRight
If NumCells > 0 And rng.Areas(1).Row + Addon <= Rows.Count Then

Set rng = Union(rng, rng.Areas(1).Offset(Addon, Addon).Resize(, NumCells))
Call TriangulateNext(Direction, rng, NumCells, Addon)
End If

Case BottomRight
If NumCells > 0 And rng.Areas(1).Row > Addon Then

Set rng = Union(rng, rng.Areas(1).Offset(-Addon, Addon).Resize(, NumCells))
Call TriangulateNext(Direction, rng, NumCells, Addon)
End If

Case BottomLeft
If NumCells > 0 And rng.Areas(1).Column + Addon <= Columns.Count Then

Set rng = Union(rng, rng.Areas(1).Offset(Addon, Addon).Resize(NumCells))
Call TriangulateNext(Direction, rng, NumCells, Addon)
End If
End Select
End Function
[/vba]

[mdmackillop]

Very neat Bob, but problem with horizontal starting selections.

[Bob Phillips]

Very neat Bob, but problem with horizontal starting selections.

Can you clarify that please Malcolm?

[mdmackillop]

See post #27

However, if the user selects a 1 row * m column array then the code should select a triangle as shown in the target output picture below

[p45cal]

As promised, see attached which contains a new toolbar with your images on.
Addresses:
-single row selected
-checks it will fit on sheet
-made a guess at which cell is to be the active cell in each case
-consolidated single sub to handle all 6 cases
-a range not selected (say a chart instead) when macro started
-multiple areas selected (it chooses the first one (that was selected))
-single cell selected
-multi-row and multi-column block uses first column only

I leave you to create an add-in from it and to show/hide the toolbar as appropriate.

Code below[vba]Sub blahAll1(Rng, Slope, Filling)
'check selection is a range
If TypeName(Rng) = "Range" Then
Set Rng = Rng.Areas(1)
If Rng.Cells.Count > 1 Then
If Rng.Rows.Count = 1 Then
'check it's going to fit:
If Rng.Columns.Count <= Rng.Row Then
Set Rng = Rng.Cells(1).Resize(Rng.Columns.Count, 1).Offset(-Rng.Columns.Count + 1)
Else
MsgBox "Won't fit above selection - try again"
Exit Sub
End If
Else
Set Rng = Rng.Columns(1)
If Rng.Rows.Count > Columns.Count - Rng.Column + 1 Then
MsgBox "Won't fit to the right of selection - try again"
Exit Sub
End If
End If
'Now a valid starting range (rng) has been established:
TypeCombi = Slope & Filling
'question: which should be active cell in each case? - I've guessed:
Set ac = Rng.Cells(Rng.Cells.Count) '1T,-1B,1N,1B
Select Case TypeCombi
' Case "-1T", "-1N", "1T": Set newrng = Rng.Cells(1): Set ac = Rng.Cells(1) '-1T,-1N,1T
Case "-1T", "-1N": Set newrng = Rng.Cells(1): Set ac = Rng.Cells(1) '-1T,-1N,1T
Case Else: Set newrng = Rng.Cells(Rng.Rows.Count)
End Select
ddd = Rng.Row + Rng.Column + Rng.Rows.Count - IIf(TypeCombi = "1T", 0, 1)

For Each cll In Rng.Resize(, Rng.Rows.Count).Cells
Select Case Slope
Case -1
xxx = (cll.Column - Rng.Column + 1) / (cll.Row - Rng.Row + 1)
Select Case Filling
Case "B": If xxx <= 1 Then Set newrng = Union(newrng, cll) '-1B
Case "N": If xxx = 1 Then Set newrng = Union(newrng, cll) '-1N
Case "T": If xxx >= 1 Then Set newrng = Union(newrng, cll) '-1T
End Select
Case Else 'Slope 1
xxx = cll.Column + cll.Row
Select Case Filling
Case "B": If xxx >= ddd Then Set newrng = Union(newrng, cll) '1B
Case "N": If xxx = ddd Then Set newrng = Union(newrng, cll) '1N
Case "T": If xxx < ddd Then Set newrng = Union(newrng, cll) '1T
End Select
End Select
Next cll
newrng.Select
Set Rng = Nothing: Set newrng = Nothing
ac.Activate
End If
End If
End Sub
[/vba]macros called by the toolbar buttons:[vba]Sub NegT()
blahAll1 Selection, -1, "T"
End Sub
Sub NegB()
blahAll1 Selection, -1, "B"
End Sub
Sub NegN()
blahAll1 Selection, -1, "N"
End Sub
Sub PosT()
blahAll1 Selection, 1, "T"
End Sub
Sub PosB()
blahAll1 Selection, 1, "B"
End Sub
Sub PosN()
blahAll1 Selection, 1, "N"
End Sub
[/vba]Thinking around the "PosN", "1B" nomenclature:
Each triangle/diagonal can be defined by 2 arguments:
1. The slope of the diagonal; positive = 1 = bottom left up to top right, negative 1 = -1 = top left to bottom right.
2. The filling, one of three: Top, Bottom or None (T,B or N)