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
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

War diese Antwort hilfreich?

Eine Person fand diese Antwort hilfreich.
0 Kommentare
Antwort, die vom Frageautor angenommen wurde
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

War diese Antwort hilfreich?

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

    War diese Antwort hilfreich?

    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

    War diese Antwort hilfreich?

    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

    War diese Antwort hilfreich?

    0 Kommentare