AW: VDA Prüfbericht - red check
01.02.2026 23:22:32
ralf_b
Moin,
mann kann auch Formelbezüge per vba auf absolut oder nicht absolut umstellen. z.B.
Sub ReplaceFormula()
' Ändert =A1*10 zu =$A1*10
Range("B1").Formula = Replace(Range("B1").Formula, "A1", "$A1")
End Sub
und bedingte Formatierungen lassen sich auch per vba modifizieren, erzeugen, löschen
Function deletefc(wsName As String, Optional strKrit As String = "")
'löscht bedingte Formatierung anhand von Kriterien.
Dim i As Long, objfc As FormatCondition
Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.EnableEvents = False
With Worksheets(wsName).Cells
For i = .FormatConditions.Count To 1 Step -1
On Error Resume Next
Set objfc = .FormatConditions(i)
' If objfc.AppliesTo.Cells.Count = 1 Then 'wenn nur auf eine Zelle bezogen
If objfc.Formula1 Like ("*" & strKrit & "*") Then 'wenn Kriterium erfüllt
objfc.Delete
End If
'End If
On Error GoTo 0
Next
End With
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Function
und hiermit kannst du deine zig bedingten Formatierungen setzen
Sub setFC(sName As String)
Dim rngLoop As Range, rngstart As Range, rngEnd As Range
Dim rngresult As Range, rngInsert As Range
Dim lastcell As Range, lastcellE As Range
Dim ws As Worksheet
Dim i As Long, cnt As Long, targetrow As Long
Set ws = Worksheets(sName)
'letzte Zelle in "Bauteil"- Zeile
Set lastcell = ws.Cells(29, ws.Columns.Count).End(xlToLeft)
'Bereich der Bauteil-Zeile
Set rngLoop = ws.Range("K29:" & lastcell.Address(0, 0))
'letzteZelle in Spalte "E"
Set lastcellE = ws.Range("E" & ws.Rows.Count).End(xlUp)
'Schleife zur Ermittlung der Adressen für die bedinge Formatierung
For i = rngLoop(1).Column To lastcell.Column Step 4
'Prüfung ob "Bauteil" in der Zelle steht
If Left(Cells(29, i), Len("Bauteil")) = "Bauteil" Then
'Prüfung ob die Zelle eine verbundene Zelle ist
If Not Cells(29, i).MergeArea Is Nothing Then
'Sammen der Zellen in einer Range
If rngresult Is Nothing Then
Set rngresult = Union(Cells(29, i)(1), Cells(29, i)(1, 3))
Else
Set rngresult = Union(rngresult, Union(Cells(29, i)(1), Cells(29, i)(1, 3)))
End If
End If
End If
Next
'achtung Schleifenende auf erste Zeile 31 des Datenbereiches setzen
For cnt = lastcellE.Row To 31 Step -1
'Prüfung ob Toleranzen eingetragen sind
If Cells(cnt, "F") > "" And Cells(cnt, "G") > "" Then
Set rngstart = Cells(cnt, "K")
If rngEnd Is Nothing Then Set rngEnd = rngstart
'Höhe des Bereiches für die bedingte Formatierung festlegen
targetrow = cnt - rngLoop.Row
'Bereich zu Zielzeile verschieben und Größe anpassen
Set rngInsert = AreasResize(rngresult, rngEnd.Row - rngstart.Row + 1)
Set rngInsert = AreasMove(rngInsert, targetrow)
' Bedingte Formatierung einfügen
With rngInsert
.FormatConditions.Delete
.FormatConditions.Add Type:=1, Operator:=2, Formula1:="=$E$" & cnt & "+$F$" & cnt, Formula2:="=$E$" & cnt & " + $G$" & cnt
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
.fONT.ColorIndex = 3
.StopIfTrue = False
End With
End With
Set rngEnd = Nothing
Else
'Endzelle für BedF Bereich setzen
If rngEnd Is Nothing Then
Set rngEnd = Cells(cnt, "K")
End If
End If
Next
End Sub
Public Function AreasResize(rng As Range, lRows As Long)
Dim ar As Range
Dim rngNeu As Range
For Each ar In rng.Areas
If rngNeu Is Nothing Then
Set rngNeu = ar.Resize(lRows, ar.Columns.Count)
Else
Set rngNeu = Union(rngNeu, ar.Resize(lRows, ar.Columns.Count))
End If
Next ar
Set AreasResize = rngNeu
End Function
Function AreasMove(rng As Range, lRows As Long)
Dim ar As Range
Dim rngNeu As Range
For Each ar In rng.Areas
If rngNeu Is Nothing Then
Set rngNeu = ar.Offset(lRows)
Else
Set rngNeu = Union(rngNeu, ar.Offset(lRows))
End If
Next ar
Set AreasMove = rngNeu
End Function
und aufgerufen wird das ganze z.b.so
Sub los()
'zum testaufruf der Subs mit parameter
deletefc ("measurement_data")
setFC( "measurement_data")
End Sub