How to merge all selected areas into one area

[iev]

Dear all,

Although I am a quite experienced programmer in C, I have just starte
learning VBA and experimenting with it through a small project i
Excel. I am reading and searching to find answers to my questions, bu
still there are some things that are too hard for me to solve at thi
point. Therefore, I would be grateful if you could help me a littl
bit.

What I am trying to do is the following: On an active worksheet, I a
selecting some areas. Let's use as an example areas C59, D15:E18
G8:I16 and J3:M13. I would like to create a new selection that contain
all the above selections and is (visually) a rectangle. For the abov
example this would be area C3:M18. It is a rectangle that starts at th
left-most column (C) and upper-most row (3) and ends at the right-mos
column (M) and lowest row (18) of all the selected areas. I have code
the following solution, but I am not certain whether it is optimal:

- Global definitions
Public OriginalSelection As Range, WorkingRange As Range

- In a subroutine
Dim i As Long
Dim TopRow As Long, BottomRow As Long
Dim LeftColumn As Long, RightColumn As Long

If Selection Is Nothing Then
GoTo ErrorMsg
End If

If TypeName(Selection) <> "Range" Then
GoTo ErrorMsg
End If

Set OriginalSelection = Selection

'
' Find the upper-left cell selected
'
TopRow = ActiveSheet.Rows.Count
LeftColumn = ActiveSheet.Columns.Count

For i = 1 To Selection.Areas.Count
If Selection.Areas(i).Row < TopRow Then
TopRow = Selection.Areas(i).Row
End If

If Selection.Areas(i).Column < LeftColumn Then
LeftColumn = Selection.Areas(i).Column
End If
Next i

'
' Find the bottom-right cell selected
'
BottomRow = TopRow
RightColumn = LeftColumn

For i = 1 To Selection.Areas.Count
If Selection.Areas(i).Row + Selection.Areas(i).Rows.Count
BottomRow Then
BottomRow = Selection.Areas(i).Row
Selection.Areas(i).Rows.Count - 1
End If

If Selection.Areas(i).Column + Selection.Areas(i).Columns.Coun

RightColumn Then

RightColumn = Selection.Areas(i).Column
Selection.Areas(i).Columns.Count - 1
End If
Next i

'
' Work with the range that starts at the upper-left cell
' and ends at the bottom-right one
'
Set WorkingRange = ActiveSheet.Range(Cells(TopRow, LeftColumn)
Cells(BottomRow - TopRow + 1, RightColumn - LeftColumn + 1))
WorkingRange.Select

Exit Sub

ErrorMsg:
MsgBox "Please select a range of cells!", vbOKOnly + vbCritical


This works, but as I already mentioned, I don't know if this is th
best way to do it. Any comments?

Thank you in advance,

Ioanni

 

[Nigel]

Here is a function that takes your input selection and returns the total
area extent of the entire selection group.

Function GetBigArea(InRange As Range) As Range
Dim x As Long, frow As Long, lrow As Long, fcol As Long, lcol As Long
frow = Rows.Count: lrow = 0: fcol = Columns.Count: lcol = 0
With InRange
For x = 1 To .Areas.Count
If frow > .Areas(x).Row Then frow = .Areas(x).Row
If .Areas(x).Row + .Areas(x).Rows.Count - 1 > lrow Then _
lrow = .Areas(x).Row + .Areas(x).Rows.Count - 1
If fcol > .Areas(x).Column Then fcol = .Areas(x).Column
If .Areas(x).Column + .Areas(x).Columns.Count - 1 > lcol Then _
lcol = .Areas(x).Column + .Areas(x).Columns.Count - 1
Next x
End With

 

[Nigel]

.... sorry missed the last two rows out of the function!!


Set GetBigArea = Range(Cells(frow, fcol), Cells(lrow, lcol))
End Function


--
Cheers
Nigel

Here is a function that takes your input selection and returns the total
area extent of the entire selection group.

Function GetBigArea(InRange As Range) As Range
Dim x As Long, frow As Long, lrow As Long, fcol As Long, lcol As Long
frow = Rows.Count: lrow = 0: fcol = Columns.Count: lcol = 0
With InRange
For x = 1 To .Areas.Count
If frow > .Areas(x).Row Then frow = .Areas(x).Row
If .Areas(x).Row + .Areas(x).Rows.Count - 1 > lrow Then _
lrow = .Areas(x).Row + .Areas(x).Rows.Count - 1
If fcol > .Areas(x).Column Then fcol = .Areas(x).Column
If .Areas(x).Column + .Areas(x).Columns.Count - 1 > lcol Then _
lcol = .Areas(x).Column + .Areas(x).Columns.Count - 1
Next x
End With

 

[Tom Ogilvy]

I think you can cut it down to one loop and use the actual addressess rather
than offsets. but the basic approach is correct since you can't depend on
a multi area range being in any particular order.

Sub AAAA()
Dim i As Long, j As Long
Dim TopRow As Long, BottomRow As Long
Dim LeftColumn As Long, RightColumn As Long

If Selection Is Nothing Then
GoTo ErrorMsg
End If
If TypeName(Selection) <> "Range" Then
GoTo ErrorMsg
End If
With ActiveSheet
TopRow = .UsedRange.Rows( _
.UsedRange.Rows.Count).Row
LeftColumn = .UsedRange.Columns( _
.UsedRange.Columns.Count).Column
BottomRow = .UsedRange.Row
Rightrow = .UsedRange.Row
End With


Set OriginalSelection = Selection

'
' Find the upper-left cell selected
'

For Each ar In Selection
If ar.Row < TopRow Then
TopRow = ar.Row
End If

If ar.Column < LeftColumn Then
LeftColumn = ar.Column
End If

i = ar.Rows(ar.Rows.Count).Row
j = ar.Columns(ar.Columns.Count).Column

If i > BottomRow Then
BottomRow = i
End If

If j > RightColumn Then
RightColumn = j
End If
Next



'
' Work with the range that starts at the upper-left cell
' and ends at the bottom-right one
'
Set WorkingRange = Range(Cells(TopRow, LeftColumn), _
Cells(BottomRow, RightColumn))
WorkingRange.Select

Exit Sub

ErrorMsg:
MsgBox "Please select a range of cells!", vbOKOnly + vbCritical

End Sub

 

[Alan Beban]

Dear all,

Although I am a quite experienced programmer in C, I have just started
learning VBA and experimenting with it through a small project in
Excel. I am reading and searching to find answers to my questions, but
still there are some things that are too hard for me to solve at this
point. Therefore, I would be grateful if you could help me a little
bit.

What I am trying to do is the following: On an active worksheet, I am
selecting some areas. Let's use as an example areas C59, D15:E18,
G8:I16 and J3:M13. I would like to create a new selection that contains
all the above selections and is (visually) a rectangle. For the above
example this would be area C3:M18. It is a rectangle that starts at the
left-most column (C) and upper-most row (3) and ends at the right-most
column (M) and lowest row (18) of all the selected areas. I have coded
the following solution, but I am not certain whether it is optimal:

- Global definitions
Public OriginalSelection As Range, WorkingRange As Range

- In a subroutine
Dim i As Long
Dim TopRow As Long, BottomRow As Long
Dim LeftColumn As Long, RightColumn As Long

If Selection Is Nothing Then
GoTo ErrorMsg
End If

If TypeName(Selection) <> "Range" Then
GoTo ErrorMsg
End If

Set OriginalSelection = Selection

'
' Find the upper-left cell selected
'
TopRow = ActiveSheet.Rows.Count
LeftColumn = ActiveSheet.Columns.Count

For i = 1 To Selection.Areas.Count
If Selection.Areas(i).Row < TopRow Then
TopRow = Selection.Areas(i).Row
End If

If Selection.Areas(i).Column < LeftColumn Then
LeftColumn = Selection.Areas(i).Column
End If
Next i

'
' Find the bottom-right cell selected
'
BottomRow = TopRow
RightColumn = LeftColumn

For i = 1 To Selection.Areas.Count
If Selection.Areas(i).Row + Selection.Areas(i).Rows.Count >
BottomRow Then
BottomRow = Selection.Areas(i).Row +
Selection.Areas(i).Rows.Count - 1
End If

If Selection.Areas(i).Column + Selection.Areas(i).Columns.Count


RightColumn = Selection.Areas(i).Column +
Selection.Areas(i).Columns.Count - 1
End If
Next i

'
' Work with the range that starts at the upper-left cell
' and ends at the bottom-right one
'
Set WorkingRange = ActiveSheet.Range(Cells(TopRow, LeftColumn),
Cells(BottomRow - TopRow + 1, RightColumn - LeftColumn + 1))
WorkingRange.Select

Exit Sub

ErrorMsg:
MsgBox "Please select a range of cells!", vbOKOnly + vbCritical


This works, but as I already mentioned, I don't know if this is the
best way to do it. Any comments?

Didn't seem to work for me; it selected C3:K16.

Alan Beban

 

[iev]

Hello again,

Alan, you are right. The code I posted is incorrect. I was trying som
things and posted incorrect code. The error is at the line:

Set WorkingRange = ActiveSheet.Range(Cells(TopRow, LeftColumn)
Cells(BottomRow - TopRow + 1, RightColumn - LeftColumn + 1))

near the end of the code. It should be:

Set WorkingRange = ActiveSheet.Range(ActiveSheet.Cells(TopRow
LeftColumn), ActiveSheet.Cells(BottomRow, RightColumn))

I would like to thank all others who replied. I will study your cod
and try to incorporate it into my code.

Thank you all for your help!

Ioanni