bedingte Formatierung per VBA
18.05.2022 11:47:53
GML
Ausgang: eine Tabelle mit einer (variablen) Anzahl von Angebotsspalten, die nicht immer an der gleichen Spalte beginnen (daher die Suche nach "Summe") in Zeile 1
Die Angebotsspalten folgen immer lückenlos aufeinander.
Was soll passieren: innerhalb dieser variablen Anzahl von Angebotsspalten soll in jeder Zeile der Minimalpreis gefunden und grün markiert werden
Anzuwenden auf: in der Beispieldatei von D6 bis I22
Da diese Tabelle "lebt", strebe ich eine Lösung per VBA/Makro an, das durch die Schaltfläche "mach mich grün" ausgelöst wird (diese Tabelle wird durch Datenimporte befüllt).
Soweit so gut, funktioniert halbwegs.
Aber nur solange, als auch in der ersten Angebotsspalte (in diesem Beispiel Spalte D) ein Preis steht.
Sobald in dieser (Start)Spalte D nichts steht (kein Angebotspreis also) funktioniert die bedingte Formatierung - scheinbar - nicht.
Eigenartigerweise passt die Darstellung wenn ich die Arbeitsmappe schließe und wieder öffne, nur nach der Makroauslösung per "mach mich grün"-Schaltfläche stimmt die bedingte Formatierungsfarbgebung nicht (Fehler von mir oder Unzulänglichkeit von Excel?).
Bitte seid nachsichtig mit meiner Spaghetti-Programmierung (bin nicht der VBA-Profi :)
Danke an alle die einen Blick darauf werfen.
Achja, Excel 2016/64 auf Win10/64
LG
hier die Beispiel-Datei :
Die Datei https://www.herber.de/bbs/user/153115.xlsm wurde aus Datenschutzgründen gelöscht
hier der Makro-Code:
'
' mach_gruen_beiKlick()
' mit bedingter Formatierung den Billigstbieter in den Angebotsspalten (mit "Summe" in
' der Kopfzeile) hervorheben
Sub mach_gruen_beiKlick()
Dim datenzeile As Integer
Dim letztezeile As Integer
Dim startspalte As Integer
Dim endespalte As Integer
Dim rangebereich$ ' quasi der Bereich über eine Zeile, in der das Minimum gefunden werden soll, in der Form Y6:AD6
' Startzeile abhängig vom Arbeitsblatt, hier für alle anderen
datenzeile = 5
' letzte Zeile des Datenblattes
' letztezeile = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
letztezeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
' Start- und Endespalte (1. Spalte mit "Summe:", letzte Spalte mit "Summe:")
' (die Angebotsvergleichspreise der verschiedenen Firmen)
' Startspalte
For lp = 1 To (ActiveSheet().Cells(datenzeile, 256).End(xlToLeft).Column) Step 1
' alle anderen Arbeitsblätter, daher "Summe" in Zeile 1 suchen
If InStr(1, Cells(1, lp), "Summe", vbTextCompare) > 0 Then
startspalte = lp
Exit For
End If
Next
' Endespalte
For lp = (ActiveSheet().Cells(datenzeile, 256).End(xlToLeft).Column) To 1 Step -1
' alle anderen Arbeitsblätter, daher "Summe" in Zeile 1 suchen
If InStr(1, Cells(1, lp), "Summe", vbTextCompare) > 0 Then
endespalte = lp
Exit For
End If
Next
Debug.Print "Datenzeilen starten in : " & datenzeile + 1
Debug.Print "Datenzeilen enden in : " & letztezeile
Debug.Print "Startspalte : " & startspalte & Chr(13) & "Endespalte : " & endespalte
Debug.Print "Startzelle als Buchstabe : " & Replace(Cells(datenzeile + 1, startspalte).Address(0, 0), 2, "")
Debug.Print "Endezelle als Buchstabe : " & Replace(Cells(datenzeile + 1, endespalte).Address(0, 0), 2, "")
' Rangebereich über eine Zeile (Address(0, 0), 2, "" -> ,2 deshalb wenn die Zeilenadresse 2stellig ist ..)
rangebereich = "$" & Replace(Cells(datenzeile + 1, startspalte).Address(0, 0), 2, """") & ":$" & _
Replace(Cells(datenzeile + 1, endespalte).Address(0, 0), 2, """")
Debug.Print "Range-Bereich als Buchstabe (über eine Zeile) : " & rangebereich
' Startzelle
Cells(datenzeile + 1, lp).Select
Cells.FormatConditions.Delete
' Wirkungsbereich festlegen
Cells(datenzeile + 1, startspalte).Activate
' Range("Y6:AD612").Select -> Rangebereich von links oben nach rechts unten ...
Range(Cells(datenzeile + 1, startspalte), Cells(letztezeile, endespalte)).Select
' diese Formel muß gebaut werden ...
' =Y6=WENN(SUMME($Y6:$AD6)>0;MIN(WENN($Y6:$AD60;$Y6:$AD6));"NIX")
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=" & Replace(Cells(datenzeile + 1, startspalte).Address(0, 0), 2, "") & "=WENN(SUMME(" & rangebereich & ")>0;MIN(WENN(" & _
rangebereich & "0;" & rangebereich & "));""NIX"")"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.color = 5296274
.TintAndShade = 0
End With
' Selection des Bereiches wieder aufheben und einfach auf die Startzelle setzen
Cells(datenzeile + 1, startspalte).Select
Selection.FormatConditions(1).StopIfTrue = False
End Sub