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-07T20:09:03+00:00

    Hallo,

    wenn du nach Spalte B filtern willst, musst du Field auf 2 setzen. Field gibt immer die Spaltenzahl an:

    .Range("A1:F" & LRow).AutoFilter Field:=2, Criteria1:="Blau"

    Claus

    War diese Antwort hilfreich?

    0 Kommentare
  2. Anonym
    2019-01-07T20:01:02+00:00

    DANKE DANKE DANKE - klappt hervorragend nachdem ich für "Blau" den Wert "Criteria1:=RGB(0, 176, _

            240), Operator:=xlFilterCellColor" eingesetzt habe. Musste erst ein wenig grübeln - bin halt nicht vom Fach.

    Habe aber etwas vergessen (so kennt man seine Daten - Ich benötige einen Filter der Spalte B nach einzelnen übrig gebliebenen DS absucht welche BLAU markiert sind. Wenn dieses klappt kann mit dem Makro von Dir der Zeileninhalt nach Tab2 kopiert werden und die Zeile(n) gelöscht werden.

    Ich hoffe Du hast nochmals einen super Einfall für nen alten Mann!!

    Gruß und Danke nochmals - Puma 5000

    A NUMMER C D E F G H I J K L M N P Q R S
    WERT 5 Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert
    WERT 1 Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert
    WERT 1 Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert
    WERT 2 Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert
    WERT 2 Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert
    WERT 6 Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert
    WERT 8 Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert
    WERT 8 Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert Wert
    zum Übertragen in Test2 brauche ich nur die Zeilen
    welche BLAU markiert sind und in Spalte  <br>B ohne Dubel sind  - ich glaub dann bin ich durch!!

    War diese Antwort hilfreich?

    0 Kommentare
  3. Anonym
    2019-01-07T14:45:57+00:00

    Hallo,

    folgender Code schaut in Spalte A nach blauen Zellen. Wenn du die Rückfrage zum Übertrag mit OK bestätigst, werden die Zeilen nach Test2 übertragen und in Test1 gelöscht:

    Sub Uebertrag()

    Dim LRow As Long

    Dim Anz As Integer, Antw As Integer

    With Sheets("Test1")

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

       .Range("A1:F" & LRow).AutoFilter Field:=1, Criteria1:="Blau"

       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

             .Range("A2:K" & LRow).Copy _

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

             .Range("A2:K" & LRow).SpecialCells(xlCellTypeVisible). _

                EntireRow.Delete

          End If

       Else

          MsgBox "Keine Daten gefunden": Exit Sub

       End If

       .AutoFilterMode = False

    End With

    End Sub

    Claus

    War diese Antwort hilfreich?

    0 Kommentare