VBA: Codeergänzung
WalterK
den folgenden Code habe ich von Sepp erhalten und funktioniert bestens. Er ist in der Personl.xls in einem Modul hinterlegt und wird mit einer Schaltfläche in der Symbolleiste aktiviert. Bei jedem Klick auf die Schaltfläche trägt der Code eine andere Formel in eine bestimmte Spalte ein.
Meine Frage: Kann man den Code so ergänzen, dass je nach eingetragener Formel bestimmte Zellen formatiert werden oder eben auch nicht. Die zu formatierenden Zellen habe ich im Code ergänzt. Bei den Formeln handelt es sich lediglich um Beispiele.
Hier der Code:
Option Explicit
Sub Formeleintragen()
Dim lngA As Long
Dim Plus As Integer
Dim strFormula(4) As String, intIndex As Integer
intIndex = GetCustProp(ActiveWorkbook, "Formelzähler", 4)
intIndex = intIndex + 1
If intIndex > 4 Then intIndex = 0
SetCustProp ActiveWorkbook, "Formelzähler", intIndex
strFormula(0) = "=Summe(A3:B3)" 'hier sollte --- Range(Cells(1, Plus+1), .Cells(1, Plus+3)) -- _
- gelb markiert werden
strFormula(1) = "=Summe(B3:F3)" 'hier sollte --- Range(Cells(1, Plus+1), .Cells(1, Plus+1)) -- _
- gelb markiert werden
strFormula(2) = "=Summe(A3:G3)" 'hier sollte --- Range(Cells(1, Plus+2), .Cells(1, Plus+2)) -- _
- gelb markiert werden
strFormula(3) = "=Summe(A3:D3)" 'hier sollte --- Range(Cells(1, Plus+3), .Cells(1, Plus+3)) -- _
- gelb markiert werden
strFormula(4) = "=WENN(A3="""";"""";WAHR)" 'hier sollte in den oben angeführten Bereichen _
nichts markiert werden
With ActiveSheet
lngA = .Cells.SpecialCells(xlCellTypeLastCell).Row 'letzte Zeilennummer in der Tabelle ü _
berhaupt
Plus = .Cells(2, .Columns.Count).End(xlToLeft).Column + 1 'Plus heißt, bis zur letzten _
belegten Spalte und dann noch 1 Spalte dazu
.Range(.Cells(3, Plus), .Cells(lngA, Plus)).FormulaLocal = strFormula(intIndex)
End With
End Sub
Private Function GetCustProp(WBook As Workbook, propName As String, Optional propValue As _
Variant) As Variant
' Wert aus Dateieigenschaft auslesen. Wenn nicht vorhanden
' Anlegen und Optional mit Startwert belegen
Dim propType As MsoDocProperties
If Not IsMissing(propValue) Then
Select Case VarType(propValue)
Case vbString
propType = msoPropertyTypeString
Case vbBoolean
propType = msoPropertyTypeBoolean
Case vbByte, vbInteger, vbLong
propType = msoPropertyTypeNumber
Case vbSingle, vbDouble
propType = msoPropertyTypeFloat
Case vbDate
propType = msoPropertyTypeDate
Case Else
End Select
End If
With WBook
On Error GoTo NoName
GetCustProp = .CustomDocumentProperties(propName).Value
Exit Function
NoName:
If Err.Number = 5 Then
Err.Clear
.CustomDocumentProperties.Add _
Name:=propName, _
LinkToContent:=False, _
Type:=propType, _
Value:=propValue
GetCustProp = propValue
End If
End With
End Function
Private Function SetCustProp(WBook As Workbook, propName As String, propValue As Variant)
' Wert in Dateieigenschaft schreiben. Wenn nicht vorhanden
' Anlegen und Wert eintragen
Dim propType As MsoDocProperties
Select Case VarType(propValue)
Case vbString
propType = msoPropertyTypeString
Case vbBoolean
propType = msoPropertyTypeBoolean
Case vbByte, vbInteger, vbLong
propType = msoPropertyTypeNumber
Case vbSingle, vbDouble
propType = msoPropertyTypeFloat
Case vbDate
propType = msoPropertyTypeDate
Case Else
End Select
With WBook
On Error GoTo NoName
.CustomDocumentProperties(propName).Value = propValue
Exit Function
NoName:
If Err.Number = 5 Then
Err.Clear
.CustomDocumentProperties.Add _
Name:=propName, _
LinkToContent:=False, _
Type:=propType, _
Value:=propValue
End If
End With
End Function