Hi Telgus,
After reviewing your file in detail, I came to the conclusion that 'Data Tables' were probably not the correct approach for your application, because it probably would require too many changes to your Excel spreadsheet design. I apologize for leading you down the wrong path.
I came up with another solution that requires you to make ZERO changes to your file, subject to the following limitations:
a. Formula in Cell D1 is changed to: '=SUM(I1:I9999)' by both the VBA routines below.
b. Each Data Area requires at least 2 Data Rows to Maintain Totals Formulas.
See the attached modified copy of your file that contains the following two Macros in Ordinary Code Module ModManageDataArea:
a. RemoveAllBlankRowsFromCurrentDataArea()
b. AddBlankRowAtTheBottomOfCurrentDataArea()
The code in red below at the top of the Module can be modified to suit your needs if you change the Spreadsheet design.
Option Explicit
Public Const sDataSheetNAME = "Blad1"
Public Const sEstmatedValueCELL = "D1"
Public Const sFirstDataCOLUMN = "A"
Public Const sLastDataCOLUMN = "I" 'Really H, but column 'I' contains 'Left Border'
Public Const sTotalCOLUMN = "I"
Sub RemoveAllBlankRowsFromCurrentDataArea()
'This removes all Blank Rows from the Current Data Area
'NOTE: TWO ROWS MUST REMAIN to preserve the Totals Formulas
'
'The First Row in the Data Area is DEFINED as the Row with 'Q' in the first position in Column 'A'
'The Last Row in the Data Area is DEFINED as the Row with a NON-BLANK Formula in Column 'I'
Dim wbData As Workbook
Dim wsData As Worksheet
Dim myRange As Range
Dim myRangeConstants As Range
Dim rCell As Range
Dim iFirstPossibleRowToDelete As Long
Dim iFirstRowInDataArea As Long
Dim iLastPossibleRowToDelete As Long
Dim iLastRowInDataArea As Long
Dim iLastRowInDataAreaBeforeTotalsRow As Long
Dim iLastRowNumberUsed As Long
Dim iMaximumNumberOfRowsAllowedToDelete As Long
Dim iNonBlankCountOnThisRow As Long
Dim iNumberOfRowsDeleted As Long
Dim iNumberOfRowsThatContainData As Long
Dim iRow As Long
Dim iRowSelected As Long
Dim iRowsSelectedCount As Long
Dim c As String
Dim sAddress As String
Dim sFormula1 As String
Dim sFormula2 As String
Dim sFormulaTemp As String
Dim sRange As String
Dim sValueColumnA As String
Dim sFormulaTotalColumn As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Initialization
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Create the Worksheet Object
Set wbData = ThisWorkbook 'The file that contains this code
Set wsData = wbData.Sheets(sDataSheetNAME)
'Get the 'Last Row Number' Used
iLastRowNumberUsed = wsData.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Verify that there are ONE OR MORE CELLS Selected in ONE ROW
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Get the Selection
'Verify at least one Cell was Selected
On Error Resume Next
sAddress = Selection.Address
If Err.Number <> 0 Then
MsgBox "NOTHING DONE." & vbCrLf & _
"There was no Cell SELECTED." & vbCrLf & vbCrLf & _
"Try again when there are one or more Cells SELECTED in the 'Data Area' of ONE ROW to be moved up or down 'One Table'."
GoTo MYEXIT
End If
On Error GoTo 0
'Get the Row Selected
iRowSelected = Selection.Row
'Get the Count of Rows Selected (MUST BE ONLY ONE)
iRowsSelectedCount = Selection.Rows.Count
If iRowsSelectedCount <> 1 Then
MsgBox "NOTHING DONE." & vbCrLf & _
"There was more than ONE ROW SELECTED." & vbCrLf & vbCrLf & _
"Try again when there are one or more Cells SELECTED in the 'Data Area' of ONE ROW to be moved up or down 'One Table'."
GoTo MYEXIT
End If
'Verify that the Row Selected was NOT 'Out of Range' (i.e. too high)
If iRowSelected > iLastRowNumberUsed Then
MsgBox "NOTHING DONE. Row " & iRowSelected & " is OUT OF RANGE." & vbCrLf & vbCrLf & _
"Try again when there are one or more Cells SELECTED in a 'Data Area' of ONE ROW in a 'Data Area'."
GoTo MYEXIT
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Verify that the Row Selected is in a 'Data Area'
'a. First Row of Data Area has 'Q' as the First Character in Column 'A'
'b. Last Row of Data has a NON-BLANK Formula in Column 'I'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Go backwards to find the first Row in the 'Data Area'
iFirstRowInDataArea = 0
iLastRowInDataArea = 0
For iRow = iRowSelected To 1 Step -1
'Look for the 'First Row'
sValueColumnA = Trim(wsData.Cells(iRow, "A").Value)
If Len(sValueColumnA) >= 2 Then
c = Left(sValueColumnA, 1)
If UCase(c) = "Q" Then
iFirstRowInDataArea = iRow
Exit For
End If
End If
'Look for the 'Last Row' - IF FOUND the Row Selected was BETWEEN two 'Data Areas'
'IGNORE the 'Row Selected' (first row to process)
If iRow <> iRowSelected Then
sFormulaTotalColumn = Trim(wsData.Cells(iRow, sTotalCOLUMN).Formula)
If Len(sFormulaTotalColumn) > 0 Then
iLastRowInDataArea = iRow
Exit For
End If
End If
Next iRow
Debug.Print iRowSelected, iFirstRowInDataArea, iLastRowInDataArea
If iFirstRowInDataArea = 0 Then
MsgBox "NOTHING DONE. Row " & iRowSelected & " is OUT OF RANGE." & vbCrLf & vbCrLf & _
"Try again when there are one or more Cells SELECTED in a 'Data Area' of ONE ROW in a 'Data Area'."
GoTo MYEXIT
End If
'Go Forward to find the Last Row in the 'Data Area'
For iRow = iRowSelected To iLastRowNumberUsed
sFormulaTotalColumn = Trim(wsData.Cells(iRow, sTotalCOLUMN).Formula)
If Len(sFormulaTotalColumn) > 0 Then
iLastRowInDataArea = iRow
Exit For
End If
'IGNORE the 'Row Selected' (first row to process)
If iRow <> iRowSelected Then
sValueColumnA = Trim(wsData.Cells(iRow, "A").Value)
If Len(sValueColumnA) >= 2 Then
c = Left(sValueColumnA, 1)
If UCase(c) = "Q" Then
iFirstRowInDataArea = iRow
Exit For
End If
End If
End If
Next iRow
Debug.Print iRowSelected, iFirstRowInDataArea, iLastRowInDataArea
If iFirstRowInDataArea > iLastRowInDataArea Then
MsgBox "NOTHING DONE. Row " & iRowSelected & " is OUT OF RANGE." & vbCrLf & vbCrLf & _
"Try again when there are one or more Cells SELECTED in a 'Data Area' of ONE ROW in a 'Data Area'."
GoTo MYEXIT
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Create the Formula for Cell 'D1'
'e.g. '=SUM(I1:I9999)'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
wsData.Range(sEstmatedValueCELL).Formula = "=SUM(" & sTotalCOLUMN & "1:" & sTotalCOLUMN & "9999" & ")"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Remove BLANK Data Rows
'NOTE: TWO ROWS MUST REMAIN to preserve the Totals Formulas
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
iFirstPossibleRowToDelete = iFirstRowInDataArea + 2
iLastPossibleRowToDelete = iLastRowInDataArea - 1
iMaximumNumberOfRowsAllowedToDelete = iLastPossibleRowToDelete - iFirstPossibleRowToDelete - 1
On Error Resume Next
For iRow = iLastPossibleRowToDelete To iFirstPossibleRowToDelete Step -1
sRange = sFirstDataCOLUMN & iRow & ":" & sLastDataCOLUMN & iRow
Set myRangeConstants = Nothing
Set myRangeConstants = wsData.Range(sRange).SpecialCells(xlCellTypeConstants)
If Not myRangeConstants Is Nothing Then
'THIS ROW CONTAINS DATA
iNumberOfRowsThatContainData = iNumberOfRowsThatContainData + 1
iNonBlankCountOnThisRow = myRangeConstants.Count
Else
'THIS ROW HAS NO DATA
If iNumberOfRowsDeleted < iMaximumNumberOfRowsAllowedToDelete Then
iNumberOfRowsDeleted = iNumberOfRowsDeleted + 1
Debug.Print "Delete Row " & iRow
wsData.Rows(iRow).Delete Shift:=xlUp
End If
iNonBlankCountOnThisRow = 0
End If
Next iRow
On Error GoTo 0
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'If only two rows remain and the Next to Last Row is BLANK
'switch the rows
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If iNumberOfRowsThatContainData < 2 Then
'Ignore Errors - Runtime Error if Range is EMPTY
On Error Resume Next
'Get the Number of Non-Blank Items on 1st Row
iRow = iFirstPossibleRowToDelete
sRange = sFirstDataCOLUMN & iRow & ":" & sLastDataCOLUMN & iRow
Set myRangeConstants = Nothing
Set myRangeConstants = wsData.Range(sRange).SpecialCells(xlCellTypeConstants)
If Not myRangeConstants Is Nothing Then
iNonBlankCountOnThisRow = myRangeConstants.Count
Else
iNonBlankCountOnThisRow = 0
End If
'Copy the Bottom Row to the Top Row (if the Top Row is BLANK)
'Clear the Bottom Row
If iNonBlankCountOnThisRow = 0 Then
Set myRange = wsData.Range(sRange)
For Each rCell In myRange
rCell.Value = rCell.Offset(1, 0).Value
rCell.Offset(1, 0).ClearContents
Next rCell
End If
'Resume Normal Error Processing
On Error GoTo 0
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Termination
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
MYEXIT:
'Clear Object Pointers
Set wbData = Nothing
Set wsData = Nothing
Set myRange = Nothing
Set myRangeConstants = Nothing
End Sub
Lewis
NOTE: Code Continued in next post due to size limitations
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks