AW: Zeilen einer ExcelTabelle auf Knopfdrck. erweitern
15.01.2014 14:40:58
Peter
Hallo Hajo, okay.
Das ist der Code einer Tabelle:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set KeyCells = Range("E10:AA140")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
' Alle Zähler auf 0 setzen
z1 = 0
z2 = 0
z3 = 0
z4 = 0
'Hintergrundfarbe aus Tabelle abfragen
For r = 8 To 140 Step 2
For s = 5 To 27
t = Cells(r, s).Interior.ColorIndex
Select Case t
Case 37: z1 = z1 + 1 'Zähler für
Case 4: z2 = z2 + 1 'Zähler für
Case -4142: z3 = z3 + 1 'Zähler für
Case 3: z4 = z4 + 1 'Zähler für
End Select
laenge = Len(Cells(r, s))
inhalt = Cells(r, s).Value
Next s
Next r
cellsoverall = (66 * 23)
relevantcells = cellsoverall - z1
'Anzahl der Zeilen in der Matrix
If z2 = 0 Or relevantcells = 0 Then
MsgBox "Please fill the cells with a status!"
reifegrad = 0
Else
reifegrad = (z2 / relevantcells) * 100
End If
'MsgBox reifegrad
Range("I1").Value = xxx
Range("D141").Value = xxx
Range("D142").Value = xxx
Range("D143").Value = xxx ' Status green
Range("D144").Value = xxx 'Status rot
Range("D145").Value = xxx ' unbearbeitete Zellen, Zellen ohne Status
MsgBox "Changed cell(s): " & Selection.Address
End If
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target = "Doubleclick to insert" & vbCrLf & "hyperlink" Then
On Error GoTo ErrExit
Application.EnableEvents = False
Cancel = True
Target = ""
If Application.Dialogs(xlDialogInsertHyperlink).Show = -1 Then
Else
Target = "Doubleclick to insert" & vbCrLf & "hyperlink"
End If
End If
ErrExit:
Application.EnableEvents = True
End Sub
Das ist der Code aus dem Modul:
Sub StatusGruen()
With Selection.Interior
.ColorIndex = 4
.Pattern = xlSolid
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.FormulaR1C1 = "Doubleclick to insert" & vbCrLf & "hyperlink"
With .Characters(Start:=1, Length:=2).Font
.Name = "Arial"
.FontStyle = "Standard"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End With
End Sub
Sub StatusRot()
With Selection.Interior
.ColorIndex = 3
.Pattern = xlSolid
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.FormulaR1C1 = "NOK"
With .Characters(Start:=1, Length:=2).Font
.Name = "Arial"
.FontStyle = "Standard"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End With
End Sub
Sub StatusNR()
With Selection.Interior
.ColorIndex = 37
.Pattern = xlSolid
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.FormulaR1C1 = "NR"
With .Characters(Start:=1, Length:=2).Font
.Name = "Arial"
.FontStyle = "Standard"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End With
End Sub
Sub StatusNoStatus()
With Selection.Interior
.ColorIndex = xlNone
End With
With Selection
.FormulaR1C1 = ""
End With
End Sub
Ich hoffe jetzt könnt ihr mir alle besser weiterhelfen.
Das Bild habe ich ja gepostet, wie die Tabelle in etwa aussieht.
Wird mein Problem, bzw mein Anliegen erkannt?
Danke.
Gruß PK
