Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Preserve Current Screen Appearance
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Preserve Current Screen Appearance
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. "Sprinks" wrote: 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
How do I move the current cell to the top of the screen? | Excel Discussion (Misc queries) | |||
Lock Screen to current view | Excel Programming | |||
changing current directory to that of the current open file | Excel Programming | |||
How to copy data from excel to power point screen by screen? | Excel Programming |