AW: Summe Dezimalklassifikation
13.05.2008 10:24:00
Renee
Hi Jessica,
Also dieser Code könnte so ungefähr funktionieren, wie du dir das vorstellst. Probier in mal in deiner Beispieltabelle aus. Er beinhaltet nun die Dezimalklassifikation & die Summenbildung (mit Auswahl Formel oder Wert). Im Moment sind die Konstanten so gesetzt, dass sie auf deine Beispielmappe (2) ausgelegt sind:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' Code for a simple decimal classification
' Row before target.row must already be filled (i.e. Row 1 contains initial start)
' the level below the one clicked is increased be 1
' clicking a empty cell below one of highest level increases highest level
Const dStart = 0 ' Start first level (e.g. 0 or 1)
Const dMinCol = 6 ' min Column
Const dMaxCol = 10 ' max Column
Const dSumCol = 17 ' Column for building a sum value or formula
Dim lCol As Long, lxCol As Long, lRow As Long
Dim sFormula As String
lRow = ActiveSheet.Cells(1, dMinCol).End(xlDown).Row
If Target.Count = 1 And Target.Row 0 Then
sFormula = sFormula & "(" & Me.Cells(Target.Row + 1, lCol).Address(0, 0) & _
":" & Me.Cells(lRow, lCol).Address(0, 0) & "=0"
Else
sFormula = sFormula & "(" & Me.Cells(Target.Row + 1, lCol).Address(0, 0) & _
":" & Me.Cells(lRow, lCol).Address(0, 0) & ">0"
lxCol = lCol
End If
Else
sFormula = sFormula & "(" & Me.Cells(Target.Row + 1, lCol).Address(0, 0) & _
":" & Me.Cells(lRow, lCol).Address(0, 0) & "=" & _
Me.Cells(Target.Row, lCol).Address(0, 0)
End If
sFormula = sFormula & ")*"
Next lCol
sFormula = sFormula & "(" & Me.Cells(Target.Row + 1, dSumCol).Address(0, 0) & _
":" & Me.Cells(lRow, dSumCol).Address(0, 0) & "))"
Select Case MsgBox("YES = Insert FORMULA" & vbCrLf & _
"NO = Insert VALUE ", vbYesNoCancel, "Insert SUM")
Case vbYes
Target.Formula = sFormula
Case vbNo
Target.Value = Evaluate(sFormula)
End Select
Application.EnableEvents = True
Cancel = True
Exit Sub
End If
If Target.Row = 1 Or Target.Count > 1 Or _
Target.Column dMaxCol Then Exit Sub
If IsEmpty(Target.Offset(-1, 0).Value) Then Exit Sub
Application.EnableEvents = False
If IsEmpty(Me.Cells(Target.Row, dMaxCol).Value) Or _
Me.Cells(Target.Row, dMaxCol).Value >= Me.Cells(Target.Row + 1, dMaxCol).Value Then
lCol = Target.Column
If IsEmpty(Target.Value) Then
Target.EntireRow.Insert (xlShiftDown)
lRow = Target.Row - 1
Else
Target.Offset(1, 0).EntireRow.Insert (xlShiftDown)
lRow = Target.Row + 1
If Target.Column lxCol
Me.Cells(lRow, lxCol).Value = Me.Cells(lRow - 1, lxCol).Value
End Select
Next lxCol
Cancel = True
Else
MsgBox "Impossible to insert level!", vbOKOnly + vbExclamation, "Insert Level"
End If
Application.EnableEvents = True
End Sub
GreetZ Renée