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 C5:D9, 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
--
ie
-----------------------------------------------------------------------
iev's Profile:
http://www.excelforum.com/member.php...fo&userid=2675
View this thread:
http://www.excelforum.com/showthread.php?threadid=40007