Push range against right screen edge
 

Trying to figure out a way to push a selected range against the right edge
of the screen by inreasing the width of column A.
It thought a loop like this would do it:

Do Until lRangeRightCol _
rngVis.Cells(rngVis.Cells(1).Row, _
rngVis.Columns.count).Column
Columns(1).ColumnWidth = Columns(1).ColumnWidth + 1
Set rngVis = ActiveWindow.VisibleRange
DoEvents
Loop

Where lRangeRightCol is the right-most column of this range.
However it doesn't work. Column A gets wider and wider, but the loop doesn't
exit.
Updating the screen doesn't help or more precisely doing
Application.ScreenUpdating = True
doesn't update the screen and maybe that is the trouble.

Any suggestions how to do this?

RBS

Push range against right screen edge
 

OK, my mistake was to widen column A.
This can be off the screen and then it won't work.
This code works reasonably well:

Sub TopRightAlignRange(rngRange As Range)

Dim bError As Boolean
Dim lRangeRightCol As Long
Dim lVisibleRangeRightCol As Long
Dim bAdjustWidth As Boolean
Dim rngVis As Range
Dim lColBefore As Long

Application.ScreenUpdating = False

On Error Resume Next

'top align top row of range
'--------------------------
ActiveWindow.ScrollRow = rngRange.Cells(1).Row

Set rngVis = ActiveWindow.VisibleRange

'this is the right-most column of the passed range
'-------------------------------------------------
lRangeRightCol = rngRange.Cells(rngRange.Cells(1).Row, _
rngRange.Columns.count).Column

'this is the column before the passed range
'------------------------------------------
lColBefore = rngRange.Cells(1).Column - 1

lVisibleRangeRightCol = _
rngVis.Cells(rngVis.Cells(1).Row, _
rngVis.Columns.count).Column


If lRangeRightCol = rngVis.Cells(rngVis.Cells(1).Row, _
rngVis.Columns.count).Column Then
Exit Sub
End If

If lRangeRightCol < lVisibleRangeRightCol Then
'first try left scroll to align right side of range to right screen
edge
'-----------------------------------------------------------------------
Do Until lRangeRightCol = _
rngVis.Cells(rngVis.Cells(1).Row, _
rngVis.Columns.count).Column Or _
lRangeRightCol _
rngVis.Cells(rngVis.Cells(1).Row, _
rngVis.Columns.count).Column Or _
ActiveWindow.ScrollColumn = 1
ActiveWindow.SmallScroll ToLeft:=1
Set rngVis = ActiveWindow.VisibleRange
If Err.Number < 0 Then
bError = True
Exit Do
End If

If lRangeRightCol _
rngVis.Cells(rngVis.Cells(1).Row, _
rngVis.Columns.count).Column Then
ActiveWindow.SmallScroll ToRight:=1
Set rngVis = ActiveWindow.VisibleRange
bAdjustWidth = True
Exit Do
End If
Loop
Else
'first try right scroll to align right side of range to right screen
edge
'-----------------------------------------------------------------------
Do Until lRangeRightCol = _
rngVis.Cells(rngVis.Cells(1).Row, _
rngVis.Columns.count).Column Or _
lRangeRightCol < _
rngVis.Cells(rngVis.Cells(1).Row, _
rngVis.Columns.count).Column
ActiveWindow.SmallScroll ToRight:=1
Set rngVis = ActiveWindow.VisibleRange
If Err.Number < 0 Then
bError = True
On Error GoTo 0
Exit Do
End If
If lRangeRightCol < _
rngVis.Cells(rngVis.Cells(1).Row, _
rngVis.Columns.count).Column Then
bAdjustWidth = True
Exit Do
End If
Loop
End If

If bError Or _
lRangeRightCol < _
rngVis.Cells(rngVis.Cells(1).Row, _
rngVis.Columns.count).Column Then
If lRangeRightCol < rngVis.Cells(rngVis.Cells(1).Row, _
rngVis.Columns.count).Column Then

Do While lRangeRightCol < _
rngVis.Cells(rngVis.Cells(1).Row, _
rngVis.Columns.count).Column
Columns(lColBefore).ColumnWidth =
Columns(lColBefore).ColumnWidth + 1
Set rngVis = ActiveWindow.VisibleRange
DoEvents
Loop
Columns(lColBefore).ColumnWidth =
Columns(lColBefore).ColumnWidth - 1
Else
Do While lRangeRightCol _
rngVis.Cells(rngVis.Cells(1).Row, _
rngVis.Columns.count).Column
Columns(lColBefore).ColumnWidth =
Columns(lColBefore).ColumnWidth - 1
Set rngVis = ActiveWindow.VisibleRange
DoEvents
Loop
End If
End If

On Error GoTo 0

Application.ScreenUpdating = True

End Sub


Still, I suspect somehow that there must be a simpler way to do this.


RBS


"RB Smissaert" wrote in message
...
Trying to figure out a way to push a selected range against the right edge
of the screen by inreasing the width of column A.
It thought a loop like this would do it:

Do Until lRangeRightCol _
rngVis.Cells(rngVis.Cells(1).Row, _
rngVis.Columns.count).Column
Columns(1).ColumnWidth = Columns(1).ColumnWidth + 1
Set rngVis = ActiveWindow.VisibleRange
DoEvents
Loop

Where lRangeRightCol is the right-most column of this range.
However it doesn't work. Column A gets wider and wider, but the loop
doesn't exit.
Updating the screen doesn't help or more precisely doing
Application.ScreenUpdating = True
doesn't update the screen and maybe that is the trouble.

Any suggestions how to do this?

RBS

Push range against right screen edge
 

RBS,

The following moves things around.
Hope it does what you want...

'----------------------
'Widens width of first column in window until last
'partially visible column in window is moved out of sight.
'Jim Cone - San Francisco, USA - September 11, 2005
Sub SizeToFit()
Dim rngVis As Excel.Range
Dim lngStart As Long
Dim lngStop As Long
Set rngVis = ActiveWindow.VisibleRange
lngStart = rngVis.Columns(rngVis.Columns.Count).Column
lngStop = rngVis.Columns(rngVis.Columns.Count).Column

Do Until lngStop = (lngStart - 1)
rngVis.Columns(1).ColumnWidth = rngVis.Columns(1).ColumnWidth + 1
Set rngVis = ActiveWindow.VisibleRange
lngStop = rngVis.Columns(rngVis.Columns.Count).Column
Loop
rngVis.Columns(1).ColumnWidth = rngVis.Columns(1).ColumnWidth - 0.5
Set rngVis = Nothing
End Sub
'-----------------------

"RB Smissaert"

wrote in message
...
Trying to figure out a way to push a selected range against the right edge
of the screen by inreasing the width of column A.
It thought a loop like this would do it:

Do Until lRangeRightCol _
rngVis.Cells(rngVis.Cells(1).Row, _
rngVis.Columns.count).Column
Columns(1).ColumnWidth = Columns(1).ColumnWidth + 1
Set rngVis = ActiveWindow.VisibleRange
DoEvents
Loop

Where lRangeRightCol is the right-most column of this range.
However it doesn't work. Column A gets wider and wider, but the loop doesn't
exit.
Updating the screen doesn't help or more precisely doing
Application.ScreenUpdating = True
doesn't update the screen and maybe that is the trouble.

Any suggestions how to do this?

RBS

Push range against right screen edge
 

Thanks, that looks better. Only thing it doesn't work on a range with more
than one column, pushing the columns other than the first off the screen.
Will adjust it bit to make it work in that situation.

RBS


"Jim Cone" wrote in message
...
RBS,

The following moves things around.
Hope it does what you want...

'----------------------
'Widens width of first column in window until last
'partially visible column in window is moved out of sight.
'Jim Cone - San Francisco, USA - September 11, 2005
Sub SizeToFit()
Dim rngVis As Excel.Range
Dim lngStart As Long
Dim lngStop As Long
Set rngVis = ActiveWindow.VisibleRange
lngStart = rngVis.Columns(rngVis.Columns.Count).Column
lngStop = rngVis.Columns(rngVis.Columns.Count).Column

Do Until lngStop = (lngStart - 1)
rngVis.Columns(1).ColumnWidth = rngVis.Columns(1).ColumnWidth + 1
Set rngVis = ActiveWindow.VisibleRange
lngStop = rngVis.Columns(rngVis.Columns.Count).Column
Loop
rngVis.Columns(1).ColumnWidth = rngVis.Columns(1).ColumnWidth - 0.5
Set rngVis = Nothing
End Sub
'-----------------------

"RB Smissaert"

wrote in message
...
Trying to figure out a way to push a selected range against the right edge
of the screen by inreasing the width of column A.
It thought a loop like this would do it:

Do Until lRangeRightCol _
rngVis.Cells(rngVis.Cells(1).Row, _
rngVis.Columns.count).Column
Columns(1).ColumnWidth = Columns(1).ColumnWidth + 1
Set rngVis = ActiveWindow.VisibleRange
DoEvents
Loop

Where lRangeRightCol is the right-most column of this range.
However it doesn't work. Column A gets wider and wider, but the loop
doesn't
exit.
Updating the screen doesn't help or more precisely doing
Application.ScreenUpdating = True
doesn't update the screen and maybe that is the trouble.

Any suggestions how to do this?

RBS

Push range against right screen edge
 

Actually this doesn't work.
I need to push a selected range against the right edge; that is the
right-most column of this selection has it's right edge against the right
screen edge.
I think the code I posted earlier seems to do a reasonable job.

RBS

"Jim Cone" wrote in message
...
RBS,

The following moves things around.
Hope it does what you want...

'----------------------
'Widens width of first column in window until last
'partially visible column in window is moved out of sight.
'Jim Cone - San Francisco, USA - September 11, 2005
Sub SizeToFit()
Dim rngVis As Excel.Range
Dim lngStart As Long
Dim lngStop As Long
Set rngVis = ActiveWindow.VisibleRange
lngStart = rngVis.Columns(rngVis.Columns.Count).Column
lngStop = rngVis.Columns(rngVis.Columns.Count).Column

Do Until lngStop = (lngStart - 1)
rngVis.Columns(1).ColumnWidth = rngVis.Columns(1).ColumnWidth + 1
Set rngVis = ActiveWindow.VisibleRange
lngStop = rngVis.Columns(rngVis.Columns.Count).Column
Loop
rngVis.Columns(1).ColumnWidth = rngVis.Columns(1).ColumnWidth - 0.5
Set rngVis = Nothing
End Sub
'-----------------------

"RB Smissaert"

wrote in message
...
Trying to figure out a way to push a selected range against the right edge
of the screen by inreasing the width of column A.
It thought a loop like this would do it:

Do Until lRangeRightCol _
rngVis.Cells(rngVis.Cells(1).Row, _
rngVis.Columns.count).Column
Columns(1).ColumnWidth = Columns(1).ColumnWidth + 1
Set rngVis = ActiveWindow.VisibleRange
DoEvents
Loop

Where lRangeRightCol is the right-most column of this range.
However it doesn't work. Column A gets wider and wider, but the loop
doesn't
exit.
Updating the screen doesn't help or more precisely doing
Application.ScreenUpdating = True
doesn't update the screen and maybe that is the trouble.

Any suggestions how to do this?

RBS