Zellen highlighten

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Bernd,
Rechtsklick auf den Tabellenreiter - Code anzeigen. In das sich öffnende Codefenster folgender Prozedur einfügen:

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim objRange As Range, objCell As Range, objFindCell As Range
    Dim lngColumn As Long
    Dim strFirstAddress As String

    Set objRange = Intersect(Target, Range("A3:A23"))

    If Not objRange Is Nothing Then

        Range("A3:A36,B2:L2").Interior.Pattern = xlPatternNone

        For Each objCell In objRange

            objCell.Interior.Color = vbBlue

            For lngColumn = 2 To 12

                If Cells(objCell.Row, lngColumn).Value = "x" Then

                    Cells(2, lngColumn).Interior.Color = vbGreen

                    With Range(Cells(24, lngColumn), Cells(36, lngColumn))

                        Set objFindCell = .Find(What:="x", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True)

                        If Not objFindCell Is Nothing Then

                            strFirstAddress = objFindCell.Address

                            Do

                                Cells(objFindCell.Row, 1).Interior.Color = vbGreen
                                Set objFindCell = .FindNext(After:=objFindCell)

                            Loop Until objFindCell.Address = strFirstAddress

                            Set objFindCell = Nothing

                        End If
                    End With
                End If
            Next

            Set objRange = Nothing

        Next
    End If
End Sub

Die Mappe als .xlsm speichern.
Gruß
Nepumuk

Hallo Bernd,
ich habe noch was eingebaut. Wenn du die Zelle A2 auswählst werden alle Farben gelöscht:

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim objRange As Range, objCell As Range, objFindCell As Range
    Dim lngColumn As Long
    Dim strFirstAddress As String

    If Target.Address = "$A$2" Then

        Range("A3:A36,B2:L2").Interior.Pattern = xlPatternNone

    Else

        Set objRange = Intersect(Target, Range("A3:A23"))

        If Not objRange Is Nothing Then

            Range("A3:A36,B2:L2").Interior.Pattern = xlPatternNone

            For Each objCell In objRange

                objCell.Interior.Color = vbBlue

                For lngColumn = 2 To 12

                    If Cells(objCell.Row, lngColumn).Value = "x" Then

                        Cells(2, lngColumn).Interior.Color = vbGreen

                        With Range(Cells(24, lngColumn), Cells(36, lngColumn))

                            Set objFindCell = .Find(What:="x", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True)

                            If Not objFindCell Is Nothing Then

                                strFirstAddress = objFindCell.Address

                                Do

                                    Cells(objFindCell.Row, 1).Interior.Color = vbGreen
                                    Set objFindCell = .FindNext(After:=objFindCell)

                                Loop Until objFindCell.Address = strFirstAddress

                                Set objFindCell = Nothing

                            End If
                        End With
                    End If
                Next
            Next

            Set objRange = Nothing

        End If
    End If
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread