Freigeben über

VBA Farbenaus Zelle in Zellenzeilen übernehmen

Anonym
2019-01-06T15:53:25+00:00

Wie übernimmt man mit Hilfe eines Makros eine Zellenfarbe einer Zelle D auf die davor liegenden Zellen A -C einer Zeile ohne darin stehende Werte zu überschreiben? 

Zelle D suchen und dann farblich nach A ausfüllen - na und das so lange bis die jeweilige Farbe abgeschlossen ist.

Ich habe es mit vielen Makroaufzeichnungen und versuchten Anpassungen versucht - aber es will nicht klappen.

Danke 

Puma5000

Beispieltabelle:

A B C D E F G
rot rot rot gelb andere Inhalte andere Inhalte andere Inhalte
keineFüllung keineFüllung keineFüllung keineFüllung andere Inhalte andere Inhalte andere Inhalte
rot rot rot keineFüllung andere Inhalte andere Inhalte andere Inhalte
keineFüllung keineFüllung keineFüllung keineFüllung andere Inhalte andere Inhalte andere Inhalte
rot rot rot blau andere Inhalte andere Inhalte andere Inhalte
keineFüllung keineFüllung keineFüllung keineFüllung andere Inhalte andere Inhalte andere Inhalte
rot rot rot keineFüllung andere Inhalte andere Inhalte andere Inhalte
rot rot rot blau andere Inhalte andere Inhalte andere Inhalte
keineFüllung keineFüllung keineFüllung keineFüllung andere Inhalte andere Inhalte andere Inhalte
keineFüllung keineFüllung keineFüllung keineFüllung andere Inhalte andere Inhalte andere Inhalte
rot rot rot keineFüllung andere Inhalte andere Inhalte andere Inhalte
rot rot rot gelb andere Inhalte andere Inhalte andere Inhalte
keineFüllung keineFüllung keineFüllung keineFüllung andere Inhalte andere Inhalte andere Inhalte
Gibt es eine Makro welcher in der Lage ist, die Farbe der Spalte D auf die Zellen A - C
der Zeile zu übertragen ohne die Werte zu beeinflussen
Microsoft 365 und Office | Excel | Für Zuhause | Windows

Gesperrte Frage. Diese Frage wurde aus der Microsoft-Support-Community migriert. Sie können darüber abstimmen, ob sie hilfreich ist, aber Sie können keine Kommentare oder Antworten hinzufügen oder der Frage folgen.

0 Kommentare

Antwort, die vom Frageautor angenommen wurde

  1. Anonym
    2019-01-11T16:09:28+00:00

    Hallo nochmals,

    da hat sich ein Fehler eingeschlichen :-(

    Probiere:

    Sub Verschieben()

    Dim i As Integer, n As Integer, Antw As Integer

    Dim LRow As Long

    Dim varRows() As Variant

    Application.ScreenUpdating = False

    With Sheets("Test1")

       LRow = .Cells(.Rows.Count, 1).End(xlUp).Row

       For i = 1 To LRow

          If .Cells(i, 2).Interior.Color = RGB(0, 176, 240) _

             And Application.CountIf(.Range("B:B"), .Cells(i, 2)) = 1 Then

             ReDim Preserve varRows(n)

             varRows(n) = i

             n = n + 1

          End If

       Next

       If n > 0 Then

          Antw = MsgBox("Es wurden " & n & " Datensätze gefunden" & Chr(10) _

             & "Sollen sie übertragen werden?", vbOKCancel, "Rückfrage")

       Else

          MsgBox "Keine Daten gefunden": Exit Sub

       End If

       If Antw = vbOK Then

          For i = LBound(varRows) To UBound(varRows)

             .Range("A" & varRows(i) & ":F" & varRows(i)).Copy _

                Destination:=Sheets("Test2").Cells(Rows.Count, 1).End(xlUp)(2)

          Next

          For i = UBound(varRows) To LBound(varRows) Step -1

             .Rows(varRows(i)).Delete

          Next

       End If

    End With

    Application.ScreenUpdating = True

    End Sub

    Claus

    Eine Person fand diese Antwort hilfreich.
    0 Kommentare

Antwort, die vom Frageautor angenommen wurde

  1. Anonym
    2019-01-10T15:18:02+00:00

    Hallo Frank,

    sorry, mein Fehler.

    Probiere:

    Sub Uebertrag()

    Dim LRow As Long

    Dim Anz As Integer, Antw As Integer, i As Integer

    Dim rngC As Range

    Dim varRows***()*** As Variant

    With Sheets("Test1")

       LRow = .Cells(.Rows.Count, 1).End(xlUp).Row

       .Range("A1:P" & LRow).AutoFilter Field:=2, Criteria1:= _

          RGB(0, 176, 240), Operator:=xlFilterCellColor

       Anz = Application.Subtotal(3, .Range("A:A")) - 1

       If Anz > 1 Then

          Antw = MsgBox("Es wurden " & Anz & " Datens?tze gefunden" & Chr(10) _

             & "Sollen sie ?bertragen werden?", vbOKCancel, "R?ckfrage")

          If Antw = vbOK Then

             For Each rngC In .Range("B2:B" & LRow).SpecialCells(xlCellTypeVisible)

                If Application.CountIf(.Range("B1:B" & LRow), rngC) = 1 Then

                   .Range("A" & rngC.Row & ":K" & rngC.Row).Copy _

                      Sheets("Test2").Cells(Rows.Count, 1).End(xlUp)(2)

                   ReDim Preserve varRows(i)

                   varRows(i) = rngC.Row

                   i = i + 1

                End If

             Next

             For i = UBound(varRows) To LBound(varRows) Step -1

                .Rows(varRows(i)).Delete

             Next

          End If

       Else

          MsgBox "Keine Daten gefunden": Exit Sub

       End If

       .AutoFilterMode = False

    End With

    End Sub

    Claus

    Eine Person fand diese Antwort hilfreich.
    0 Kommentare

58 zusätzliche Antworten

Sortieren nach: Am hilfreichsten
Am hilfreichsten Neueste Älteste
  1. Anonym
    2019-01-07T08:40:06+00:00

    Hallo,

    dann probiere es so:

    Sub Farbe()

    Dim LRow As Long

    Dim rngC As Range

    With ActiveSheet

       LRow = .Cells(.Rows.Count, "D").End(xlUp).Row

       For Each rngC In .Range("D1:D" & LRow)

          If rngC.Interior.ColorIndex = xlNone Then

             rngC.Offset(, -3).Resize(1, 3).Interior.ColorIndex = xlNone

          Else

             rngC.Offset(, -3).Resize(1, 3).Interior.Color = rngC.Interior.Color

          End If

       Next

    End With

    End Sub

    Claus

    0 Kommentare
  2. Anonym
    2019-01-06T19:25:37+00:00

    Guten Abend

    Danke - hat erst mal geklappt - bis auf - Auch die Zeilen rot mit Farbe keine Füllung in D sollten als Farbe keine Füllung erhalten. Wenn das überhaupt geht?!?

    Gruß und Danke nochmal - Puma

    0 Kommentare
  3. Anonym
    2019-01-06T17:30:14+00:00

    Hallo,

    probiere mal:

    Sub Farbe()

    Dim LRow As Long

    Dim rngC As Range

    With ActiveSheet

       LRow = .Cells(.Rows.Count, "D").End(xlUp).Row

       For Each rngC In .Range("D1:D" & LRow)

          If rngC.Interior.ColorIndex <> xlNone Then

             rngC.Offset(, -3).Resize(1, 3).Interior.Color _

                = rngC.Interior.Color

          End If

       Next

    End With

    End Sub

    Claus

    0 Kommentare