Challenge: Triangle Area Select tool

[xluser2007]

Hi All,

At work we often work with triangulated data in Excel.

As such, could anyone please show how to code in the most robust and elegant manner a macro to sleect a triangular area if a vertical column is selected.

I have attached a picture to show the selected column, and the target output i.e. a top-triangle selection, with the bottom left cell being the "Activecell".

If anyone could please assist in writing the macro that would be appreciated.

regards,

[xluser2007]

And here is the target output i.e. the triangular area selected based on the orginal vertical column selected.

Any help sincerely appreciated.

[HaHoBe]

Hi,

no error handling included, no check for more than one selected area or more than one column:

Dim lngCounter As Long
Dim lngRowCount As Long
Dim rngTriang As Range

Set rngTriang = Selection
lngRowCount = rngTriang.Row

For lngCounter = Selection.Rows.Count To 1 Step -1
    Set rngTriang = Union(rngTriang, Range(Cells(lngRowCount, Selection.Column), Cells(lngRowCount, Selection.Column + lngCounter - 1)))
    lngRowCount = lngRowCount + 1
Next lngCounter

rngTriang.Select

Set rngTriang = Nothing

Ciao,
Holger

[mdmackillop]

.....with the bottom left cell being the "Activecell"

A couple of lines more for the ActiveCell part

[vba]
Dim lngCounter As Long
Dim lngRowCount As Long
Dim rngTriang As Range
Dim AC As Range

Set rngTriang = Selection
Set AC = rngTriang(rngTriang.Cells.Count)

lngRowCount = rngTriang.Row
For lngCounter = Selection.Rows.Count To 1 Step -1
Set rngTriang = Union(rngTriang, Range(Cells(lngRowCount, Selection.Column), Cells(lngRowCount, Selection.Column + lngCounter - 1)))
lngRowCount = lngRowCount + 1
Next lngCounter

rngTriang.Select
AC.Activate

Set rngTriang = Nothing
Set AC = Nothing

[/vba]

[mdmackillop]

Hi Holger,
If you use the green VBA button, rather than Code tags, your code will be formatted as shown.
Regards
MD

[mdmackillop]

Elegance is in the eye of the beholder. No "better" than Holgers code, just a different method of referencing.
[VBA]
Dim x As Long, y As Long, z As Long
Dim rngTriang As Range
Dim Rng As Range
Set Rng = ActiveCell
Set rngTriang = Rng
x = Selection.Cells.Count
For z = x To 1 Step -1
Set rngTriang = Union(rngTriang, Rng.Offset(y).Resize(, z))
y = y + 1
Next
rngTriang.Select
Rng.Offset(x - 1).Activate
Set rngTriang = Nothing

[/VBA]

[Bob Phillips]

[vba]

Public Function Triangulate()
Dim NumRows As Long
Dim Addrows As Long
Dim rng As Range

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

Private Function TriangulateNext(ByRef rng As Range, ByRef NumRows As Long, ByRef Addrows As Long)

NumRows = NumRows - 1
Addrows = Addrows + 1
If NumRows > 0 Then

Set rng = Union(rng, rng.Areas(1).Offset(0, NumRows).Resize(Addrows))
Call TriangulateNext(rng, NumRows, Addrows)
End If
End Function
[/vba]

[p45cal]

not necessarily more efficient nor elegant but a different approach[vba]Sub blah()
Set rng = Selection
Set AC = rng(rng.Cells.Count)
For Each cll In rng.Resize(, rng.Rows.Count - 1).Offset(, 1)
If cll.Column - Selection.Column + cll.Row - Selection.Row < Selection.Rows.Count then Set rng = Union(rng, cll)
Next cll
rng.Select
AC.Activate
End Sub [/vba]and with fewer calculations:[vba]Sub blah()
Set rng = Selection
Set AC = rng(rng.Cells.Count)
ddd = rng.Row + rng.Column + rng.Rows.Count
For Each cll In rng.Resize(, rng.Rows.Count - 1).Offset(, 1)
If cll.Column + cll.Row < ddd Then Set rng = Union(rng, cll)
Next cll
rng.Select
AC.Activate
End Sub
[/vba]

[xluser2007]

Holger, mdm, and Bob,

All brilliant solutions to the problem. I had not used Union before, so brilliant to learn from.

I have just a few queries and amendments that i would like to make. Could you please kindly assist. Bob, the way you have structured your solution with the "TraingulateNext" Function may lend itself naturally to the following extensions:

1. How can one error-handle the case where the user selects a chart and runs the macro instead of a column of cells?
   
2. If the user selects more than one column of contagious cells, then I would only like the traingle to extend from the first column, i.e. ideally one should only select one vertical column, but if they select more than one then triangulate from the first column.
3. If the user selects a bunch of non-contagious columns of cells, then again I would like to only start from the first column area and triangulate from there.
4. At work we also do the following triangulations (Please see attached picture below for the types of traingulations and diagonl-only selections). Could the macros be easily extended to allow for these combinations? Bob, in particular I feel that your TriangulateNext UDF could eb catered for this, but I am finding it hard to adapt.

- The combinations are Bottom Left, Bottom-Right, Top-Left (which you have already done), Top-Right, Diagonal Left-to-Right, and Diagonal Right-to_Left.

Thanks sincerely for your kind help offered thus far, any help to extend this is appreciated.

If the above can be easily acheived then, I would like to make this as an addin for my personal use at work. This would be amazingly helpful .

[xluser2007]

not necessarily more efficient nor elegant but a different approach[vba]Sub blah()
Set rng = Selection
Set AC = rng(rng.Cells.Count)
For Each cll In rng.Resize(, rng.Rows.Count - 1).Offset(, 1)
If cll.Column - Selection.Column + cll.Row - Selection.Row < Selection.Rows.Count then Set rng = Union(rng, cll)
Next cll
rng.Select
AC.Activate
End Sub [/vba]and with fewer calculations:[vba]Sub blah()
Set rng = Selection
Set AC = rng(rng.Cells.Count)
ddd = rng.Row + rng.Column + rng.Rows.Count
For Each cll In rng.Resize(, rng.Rows.Count - 1).Offset(, 1)
If cll.Column + cll.Row < ddd Then Set rng = Union(rng, cll)
Next cll
rng.Select
AC.Activate
End Sub
[/vba]

Hi pascal,

I just saw your elegant solution.

Really learning so many techniques from VBAX experts.

Thank you kindly.

[xluser2007]

I have just attached the following workbook, which has your macros set up with buttons for ease of testing purposes.

[p45cal]

all of 'em:[vba]Sub blah() 'top left
Set rng = Selection
Set AC = rng(rng.Cells.Count)
ddd = rng.Row + rng.Column + rng.Rows.Count
For Each cll In rng.Resize(, rng.Rows.Count - 1).Offset(, 1)
If cll.Column + cll.Row < ddd Then Set rng = Union(rng, cll)
Next cll
rng.Select
AC.Activate
End Sub
Sub blah3() 'bottom left
Set rng = Selection
Set AC = rng(rng.Cells.Count)
For Each cll In rng.Resize(, rng.Rows.Count - 1).Offset(, 1)
If (cll.Column - Selection.Column + 1) / (cll.Row - Selection.Row + 1) <= 1 Then Set rng = Union(rng, cll)
Next cll
rng.Select
AC.Activate
End Sub
Sub blah4() 'top right
Set rng = Selection
Set newrng = Selection.Cells(1)
Set AC = Selection.Cells(1)
For Each cll In rng.Resize(, rng.Rows.Count - 1).Offset(, 1)
If (cll.Column - Selection.Column + 1) / (cll.Row - Selection.Row + 1) >= 1 Then Set newrng = Union(newrng, cll)
Next cll
newrng.Select
AC.Activate
End Sub
Sub blah5() 'diagonal top left to bottom right
Set rng = Selection
Set newrng = Selection.Cells(1)
Set AC = Selection.Cells(1)
For Each cll In rng.Resize(, rng.Rows.Count - 1).Offset(, 1)
If (cll.Column - Selection.Column + 1) / (cll.Row - Selection.Row + 1) = 1 Then Set newrng = Union(newrng, cll)
Next cll
newrng.Select
AC.Activate
End Sub
Sub blah6() 'diagonal bottom left to top right
Set rng = Selection
Set AC = rng(rng.Cells.Count)
Set newrng = AC
ddd = rng.Row + rng.Column + rng.Rows.Count - 1
For Each cll In rng.Resize(, rng.Rows.Count - 1).Offset(, 1)
If cll.Column + cll.Row = ddd Then Set newrng = Union(newrng, cll)
Next cll
newrng.Select
AC.Activate
End Sub
Sub blah7() 'bottom right
Set rng = Selection
Set AC = rng(rng.Rows.Count)
Set newrng = AC
ddd = rng.Row + rng.Column + rng.Rows.Count - 1
For Each cll In rng.Resize(, rng.Rows.Count - 1).Offset(, 1)
If cll.Column + cll.Row >= ddd Then Set newrng = Union(newrng, cll)
Next cll
newrng.Select
AC.Activate
End Sub
[/vba]I haven't got time now to do this but they each have similar code so it shouldn't be too hard to consolidate them into a single sub to which you could pass arguments.

[mdmackillop]

Variations on a theme. You can easily fix which you need to select as the ActiveCell opn completion

[VBA]
Sub Tri1()
Dim x As Long, y As Long, z As Long
Dim rngTriang As Range
Dim Rng As Range
Selection.Columns(1).Select
Set Rng = ActiveCell
Set rngTriang = Rng
x = Selection.Cells.Count
For z = x To 1 Step -1
Set rngTriang = Union(rngTriang, Rng.Offset(y).Resize(, z))
y = y + 1
Next
rngTriang.Interior.ColorIndex = 1
Rng.Offset(x - 1).Activate
Set rngTriang = Nothing
End Sub

Sub Tri2()
Dim x As Long, y As Long, z As Long
Dim rngTriang As Range
Dim Rng As Range
Selection.Columns(1).Select
Set Rng = ActiveCell
Set rngTriang = Rng
x = Selection.Cells.Count
For z = 1 To x
Set rngTriang = Union(rngTriang, Rng.Offset(y).Resize(, z))
y = y + 1
Next
rngTriang.Interior.ColorIndex = 22
Rng.Offset(x - 1).Activate
Set rngTriang = Nothing
End Sub

Sub Tri3()
Dim x As Long, y As Long, z As Long
Dim rngTriang As Range
Dim Rng As Range
Selection.Columns(1).Select
Set Rng = ActiveCell
Set rngTriang = Rng
x = Selection.Cells.Count
For z = 1 To x
Set rngTriang = Union(rngTriang, Rng.Offset(y, 1 - z).Resize(, z))
y = y + 1
Next
rngTriang.Interior.ColorIndex = 3
Rng.Offset(x - 1).Activate
Set rngTriang = Nothing
End Sub

Sub Tri4()
Dim x As Long, y As Long, z As Long
Dim rngTriang As Range
Dim Rng As Range
Selection.Columns(1).Select
Set Rng = Selection(Selection.Cells.Count)
Set rngTriang = Rng
x = Selection.Cells.Count
For z = 1 To x
Set rngTriang = Union(rngTriang, Rng.Offset(y, 1 - z).Resize(, z))
y = y - 1
Next
rngTriang.Interior.ColorIndex = 4
Rng.Offset(x - 1).Activate
Set rngTriang = Nothing
End Sub

Sub Diag1()
Dim x As Long, y As Long, z As Long
Dim rngTriang As Range
Dim Rng As Range
Selection.Columns(1).Select
Set Rng = ActiveCell
Set rngTriang = Rng
x = Selection.Cells.Count
For z = 1 To x
Set rngTriang = Union(rngTriang, Rng.Offset(y, 1 - z))
y = y + 1
Next
rngTriang.Interior.ColorIndex = 14
Rng.Offset(x - 1).Activate
Set rngTriang = Nothing
End Sub

Sub Diag2()
Dim x As Long, y As Long, z As Long
Dim rngTriang As Range
Dim Rng As Range
Selection.Columns(1).Select
Set Rng = ActiveCell
Set rngTriang = Rng
x = Selection.Cells.Count
For z = 1 To x
Set rngTriang = Union(rngTriang, Rng.Offset(y, z - 1))
y = y + 1
Next
rngTriang.Interior.ColorIndex = 16
Rng.Activate
Set rngTriang = Nothing
End Sub

[/VBA]

[xluser2007]

all of 'em:I haven't got time now to do this but they each have similar code so it shouldn't be too hard to consolidate them into a single sub to which you could pass arguments.

Thanks very much p45cal, I really appreciate your help and time on this one.

It is amazing to see the elegant coding you have used.

Just pasted yours in a test workbook, as attached.

Just with regard to my earlier post, a few queries:

1. When the user selects a block of contagious cells e.g. 3 rows * 4 cols, could the triangle be made to start from the first Column only?
2. If the user selects non-contagious cells e.g A1:A5, B1:B5, E10:E15, could the traingle be made to start from the first area i.e. A1:A5?
3. Later, if you have the time, I would love to understand how to consolidate the macros into a single code. I understand that you are busy and fully appreciate your help, but learning this would be a cool thing to know how to do.

kind regards,

[mdmackillop]

Use this line from my code to get the first column
[VBA]
Selection.Columns(1).Select

[/VBA]

[xluser2007]

Use this line from my code to get the first column
[vba]
Selection.Columns(1).Select

[/vba]

Brilliant malcolm, that answers the contagious and non-contagious cells question!

[p45cal]

Just with regard to my earlier post, a few queries:

In haste, I'm gone 'til Monday or Tuesday.

When the user selects a block of contagious cells e.g. 3 rows * 4 cols, could the triangle be made to start from the first Column only?

Yes, start with Selection.columns(1).select. But with all this swine flu about I wouldn't want to be anywhere near these cells.

If the user selects non-contagious cells e.g A1:A5, B1:B5, E10:E15, could the traingle be made to start from the first area i.e. A1:A5?

Possibly, with the likes of Selection.areas(1).select, but haven't time to test/refine.

Later, if you have the time, I would love to understand how to consolidate the macros into a single code. I understand that you are busy and fully appreciate your help, but learning this would be a cool thing to know how to do.

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

[mdmackillop]

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

[Aussiebear]

It was interestig to note that in testing the initial file uploaded by xluser2007, the following results occur

Single cell selection: p45cal's error out and all others just sit there.
3 vertical cell selection: All work as intended.

However if you select 3 horizontal cells: p45cal's errors out, Xld's retains the user highlighted format, Holger's code reverses the user highlighted format, and MD's functions as if 3 vertical cells were selected.

[mdmackillop]

... and MD's functions as if 3 vertical cells were selected.

Lateral thinking!!!