Preserve Current Screen Appearance

[Sprinks]

Version: MS Office Excel 2003 SP2

Our office estimates construction projects for architectural clients. We
use templates that look something like this. Each page is a static 60 lines
long.

A B C D E F
Code Description Qty Unit Unit Cost Cost
1 Footings - A 3 LF 25.00 75.00
2 - B 25 LF 30.00 750.00
3 Deep Foundations 1 LS --- NIC
....
46

The "Code" column is simply a label. Frequently in using the templates, we
need to insert a few lines in the middle or move a block up under the
previous block. By "insert", I really mean cutting and pasting columns B
through F, and then erasing the unneeded fragments that remain. Normally,
all formulae in column F multiply the values in columns C & E, but we may
overwrite the formula to some text value such as "NIC" or "TBD", so after
copying our block, we may need to reassign the formula to the Column F cells.

To simplify this process, I've created 2 macros, MoveBlockDown and
MoveBlockUp, which work fine so far. Whey they are complete, however, the
screen often is not in the state it was in prior to the macro being invoked,
even though I have returned the cursor to its original location.

Is there a way to preserve the screen state, i.e., which is the first
visible row?

Thank you. I've attached code for one of them for reference, if necessary.

Sprinks

' Mini-procedure to fill formulae into Column F
Sub FillTotalColumn(rngParam As Range)
Dim Cell As Range
For Each Cell In rngParam
Cell.Formula = "=ROUND((C" & Trim(Str(Cell.Row)) & "*E" & _
Trim(Str(Cell.Row)) & "), -1)"
Next Cell
End Sub

' Finds the row of the next block, or top or bottom of existing block
Function NextBlockRow(rngStart As Range, intDirection As Integer) As Integer
Dim rngCurrentSelection As Range
Set rngCurrentSelection = Selection
rngStart.Select
Selection.End(intDirection).Select
NextBlockRow = ActiveCell.Row
rngCurrentSelection.Select
End Function

Sub MoveBlockDown()
' Moves contiguous block down user-specified number of lines
' Will not overwrite existing data

On Error GoTo ErrorHandler

Dim intCRow As Integer ' row of cell from which macro invoked
Dim intCCol As Integer ' column of cell from which macro invoked
Dim intLPDRow As Integer ' last possible data row on page
Dim intLBRow As Integer ' last data row in contiguous block
Dim varIRows As Variant ' number of rows to insert
Dim intAvailableRows As Integer ' rows between end of block and first data
Dim rngWorking As Range ' working cell or range
Dim rngBlock As Range ' block to move
Dim Cell As Range
Dim strFormula As String
Dim strErrorMsg As String

strErrorMsg = ""
intCRow = ActiveCell.Row
intCCol = ActiveCell.Column

' Verify that current row has a description
If Cells(intCRow, 2) = "" Then
strErrorMsg = "Insert invoked from a blank row; nothing to insert."
GoTo SubExit
End If

' Get last row in contiguous block and set rngBlock
If Cells(intCRow + 1, 2) = "" Then ' At very last row or last
of current block
intLBRow = intCRow
Else
Set rngWorking = Cells(intCRow, 2) ' Column B on
current row
intLBRow = NextBlockRow(rngWorking, xlDown)
End If
Set rngBlock = Range(Cells(intCRow, 2), Cells(intLBRow, 6))

' Get last possible data row
Set rngWorking = Cells(intCRow, 1) 'Column A on current row
If Cells(intCRow + 1, 1) = "" Then
strErrorMsg = "Cannot insert a line here."
GoTo SubExit
Else
intLPDRow = NextBlockRow(rngWorking, xlDown)
End If

' Determine number of available rows
intAvailableRows = intLPDRow - intLBRow
Set rngWorking = Range(Cells(intLBRow + 1, 2), Cells(intLPDRow, 5))
For Each Cell In rngWorking
If Cell <> "" Then
intAvailableRows = Cell.Row - intLBRow - 1
Exit For
End If
Next Cell

' Input number of rows to insert
rngBlock.Select
varIRows = InputBox("Input number of rows to insert or Cancel", "Insert Rows")

If varIRows = "" Then
Else
varIRows = Int(Val(varIRows))
If varIRows <= intAvailableRows Then

' Copy block and clear previous contents
rngBlock.Copy ActiveSheet.Cells(intCRow + varIRows, 2)
Set rngBlock = Range(Cells(intCRow, 2), Cells(intCRow + varIRows -
1, 6))
rngBlock.ClearContents

' Reset formulas for column F in blank rows
Set rngBlock = Range(Cells(intCRow, 6), Cells(intCRow + varIRows -
1, 6))
Call FillTotalColumn(rngBlock)
Else
strErrorMsg = "Number of rows exceeds space available."
GoTo SubExit
End If
End If

SubExit:
If strErrorMsg <> "" Then
MsgBox strErrorMsg, vbOKOnly, "Exiting Procedure"
End If
ActiveSheet.Cells(intCRow, intCCol).Select
Set rngWorking = Nothing
Set rngBlock = Nothing
Set Cell = Nothing
Exit Sub

ErrorHandler:
MsgBox "Error detected. Please write record and contact administrator:
" & Err.Description
GoTo SubExit

End Sub

 

[JNW]

If you are just looking to return the view to the original view try adding
the following at the end of the appropriate macro:

Range("Z60").Activate 'this should be a cell that is somewhere off the
original screen
Range(x).Activate 'Substitute the range that you want in the top left corner
of the screen for x

It's more of a workaround but should do what your looking for.