Script anpassen, erst ab Zeile 4
02.06.2017 08:49:59
peterlijaba@gmail.com
Ich habe im Netz untenstehendes Script gefunden. Die Zeilen werden Blockweise, gemäss angegebener Spalte, grau/weiss eingefärbt und das auch bei aktivem Autofilter, das ist genau das was ich brauche, benötige jedoch noch zwei Anpassungen:
1. Die Formatierung beginnt bereits bei der zweiten Zeile, sollte jedoch erst ab der 4. Zeile sein (Titelzeilen 1-3, Autofilter in Zeile 3, Daten ab Zeile 4).
Ich habe versucht an der unten eingefügten Codestelle den Anfang der Bedingten Formartierung anzupassen:
'bedingte Formatierung setzen
Range(Cells(2, 1), Cells(lzeile, lspalte + 1)).Select
2. Gemäss unten eingefügter Codestelle, wird mit einem Popupfenster abgefragt, nach welcher Spalte formatiert werden soll, ich möchte jedoch nicht wählen müssen, sondern es soll immer nach Spalten C, resp. nach der Spalte "Produkt" formatiert werden.
'Inputbox mit Auswahlmöglichkeit
msgTitel = "Eingabe erforderlich!"
Set rngSelect = Application.InputBox _
(Prompt:="Bitte eine Zelle in der Spalte wählen " & vbCrLf & _
"nach welcher BLOCKWEISE markiert werden soll" & vbCrLf & vbCrLf & _
"(Bei Eingabe eines Zellbereichs wird nur die Spalte " & vbCrLf & _
"aus der ersten Zelladresse ausgelesen)", _
Title:=msgTitel, Type:=8)
Vollständiges Sript:
Sub Blockmarkierung_bedingte_Fomatierung()
Dim lzeile, lspalte, spdiff, i As Long
Dim farbe1, farbe2, X As Boolean
Dim rngSelect As Range
Dim msgTitel As String
'Makro zum Setzen einer Blockmarkierung aufgrund einer ausgewählten Spalte mit BEDINGTER _
FORMATIERUNG!!!
'Hinweis: Überschriftszeile muss durchgehend vorhanden sein!!!
'Ermitteln der letzten gefüllten Zeile in Spalte C
lzeile = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
'Ermitteln der letzten gefüllten Spalte in Zeile 3
lspalte = ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column
On Error Resume Next
'Inputbox mit Auswahlmöglichkeit
msgTitel = "Eingabe erforderlich!"
Set rngSelect = Application.InputBox _
(Prompt:="Bitte eine Zelle in der Spalte wählen " & vbCrLf & _
"nach welcher BLOCKWEISE markiert werden soll" & vbCrLf & vbCrLf & _
"(Bei Eingabe eines Zellbereichs wird nur die Spalte " & vbCrLf & _
"aus der ersten Zelladresse ausgelesen)", _
Title:=msgTitel, Type:=8)
'Bildschirmaktualisierung ausschalten
Application.ScreenUpdating = False
If Not rngSelect Is Nothing Then
'Ermittlung der Anzahl von Spalten, welche zwischen der letzten und der Suchspalte liegen
spdiff = lspalte + 1 - rngSelect.Column
'vorhandene bedingte Formatierung löschen
Cells.FormatConditions.Delete
'Hilfspalte anlegen
'Überschrift für Hilfsspalte
'Überschrift Hilfsspalte
Cells(1, lspalte + 1).FormulaR1C1 = "Hilfsspalte wg. bedingter Format."
'Formel Hilfspalte
Range(Cells(2, lspalte + 1), Cells(lzeile, lspalte + 1)).FormulaR1C1 = _
"=IF(SUBTOTAL(3,RC[-" & spdiff & "]),RC[-" & spdiff & "],R[-1]C)"
'bedingte Formatierung setzen
Range(Cells(2, 1), Cells(lzeile, lspalte + 1)).Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=REST(SUMMENPRODUKT(N(" & Cells(1, lspalte + 1).Address & ":" & Cells(1, lspalte + 1). _
Address(0) & "" & Cells(2, lspalte + 1).Address & ":" & Cells(2, lspalte + 1).Address(0) & "));2)"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249946592608417
End With
Selection.FormatConditions(1).StopIfTrue = False
'Ausblenden der Hilfsspalte
Cells(1, lspalte + 1).Columns.EntireColumn.Hidden = True
Else
MsgBox "Keine Zelle wurde ausgewählt!" & vbCrLf & "Das Makro wird beendet", _
vbOKOnly + vbInformation, "Hinweis"
End If
'Markieren von Zelle A2
Range("A2").Select
'Bildschirmaktualisierung einschalten
Application.ScreenUpdating = True
End Sub
Danke für eure geschätzte Unterstützung.
Viele Grüsse,
Peter