AW: Kopieren mit Bedingter Formatierung
21.10.2020 07:06:14
Hajo_Zi
Du möchtest keine XLSM Datei hochladen da Du den Code selber an Deine Bedingungen anpassen möchtest.
Viel Erfoilg
Ich bin dann raus, da Lösung erstellt.
Sub BedingteKorrigieren()
'* 16.04.16 *
'* erstellt von Karin (Beverly), http://Excel-Inn.de
'* Beverly_Forums@web.de *
Dim intSpalte As Integer
Dim intZaehler As Integer
Dim strBereich As String
Dim arrBereich
Dim intLetzte As Long
Dim lngLetzte As Long
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Projektinformationssystem")
intLetzte = IIf(IsEmpty(.Cells(9, .Columns.Count)), .Cells(9, .Columns.Count).End( _
xlToLeft).Column, .Columns.Count)
lngLetzte = .Rows.Count
.Range(.Cells(10, 1), .Cells(lngLetzte, intLetzte)).FormatConditions.Delete
For intSpalte = 1 To intLetzte
If .Cells(2, intSpalte).FormatConditions.Count > 0 Then
For intZaehler = 1 To .Cells(2, intSpalte).FormatConditions.Count
ReDim arrBereich(0 To 1)
strBereich = .Cells(2, intSpalte).FormatConditions(intZaehler).AppliesTo. _
Areas(1).Address
If IsNumeric(Right(strBereich, 1)) Then
arrBereich(0) = Range(strBereich).Cells(1).Address
arrBereich(1) = Range(strBereich).Cells(Range(strBereich).Cells.Count). _
Address
arrBereich(0) = Left(arrBereich(0), InStrRev(arrBereich(0), "$") - 1)
arrBereich(1) = Left(arrBereich(1), InStrRev(arrBereich(1), "$") - 1)
strBereich = Join(arrBereich, ":")
.Cells(2, intSpalte).FormatConditions(intZaehler).ModifyAppliesToRange _
Range(strBereich)
End If
Next intZaehler
End If
Next intSpalte
End With
Application.ScreenUpdating = True
End Sub
Gruß Hajo