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: Neueste
Am hilfreichsten Neueste Älteste
  1. Anonym
    2019-01-21T09:30:14+00:00

    Hallo Frank,

    der Thread wird langsam unübersichtlich. Schau mal in mein Profil und schreibe mir eine Mail. Erkläre darin mal, was es mit den verschiedenen Blättern genau auf sich hat. Ein Makro gehört nur einmal in eine Mappe.

    Claus

    War diese Antwort hilfreich?

    0 Kommentare
  2. Anonym
    2019-01-21T09:15:10+00:00

    Guten Morgen Claus - ich dachte nun habe ich alles zusammen - aber es funktioniert nicht - Meine Tabelle hat verschiedene Tabellenblätter.

    Die Blätter sind in den Zellen und Zeilen unterschiedlich. Ich lese täglich Sheet's auf in die einzelnen Tabellen. dazu habe ich Deinen Sub in ein extra Modul kopiert sowie in meine Bearbeitungsmodul - aber wenn ich es anwende kommt Laufzeitfehler '9'  Index außerhalb gültigen Bereich  ->> was habe ich übersehen / was mache ich falsch? Den 'Sub Test() habe ich auf Text gestellt da sich der Rest ja im Makro befindet. 

    Ich bin am ENDE --> Gruß Frank

    Sub Rent2019AuflL?sch() ' RentAufl Makro

        Dim ende As Long

        Dim sb As Long

        Dim ze As Long

        Dim se As Long

        'zb = 16

        sb = 1

        ze = 200

        se = 20

    Selection.AutoFilter   'Autofilter AUS

    Dim Antwort

    Antwort = MsgBox("Tabellen auflesen??", vbYesNoCancel, "ACHTUNG - ACHTUNG - ACHTUNG")   'Variablendefinition f?r MsgBox Abfrage

    '----Bei MsgBox Antwort JA--es wird Fahrzeuge.xlsx aufgelesen--------------

    If Antwort = vbYes Then    'bei JA

    ende = Cells(Rows.Count, 1).End(xlUp).Row  'letzte benutzte Zelle in Spalte 1 finden - With ActiveSheet

    'Stop

    Range(Cells(ende, sb), Cells(ze, se)).Select  'Letzte Zeile suchen ENDE muss am Anfang stehen

    'Stop

    Selection.FillDown       'ab tabellenende ENDE bis t200 wird gedoppelt

    'Stop

    '------------------------------------------------------------------------------------------------------

    'Sub Test()

    Dim wbkQ As Workbook, wbkZ As Workbook

    Dim wshQ As Worksheet, wshZ As Worksheet

    Dim LRow As Long

    Dim i As Integer

    'Qellmappe und Quellblatt

    Set wbkQ = Workbooks("FahrzeugeKADEA.xlsx"): Set wshQ = wbkQ.Sheets("Sheet")

    'Zielmappe und Zielblatt

    Set wbkZ = ThisWorkbook: Set wshZ = wbkZ.Sheets("RentKADEA")

    With wshQ

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

       .Cells(LRow, 2).Resize(, 24).ClearContents

       .Range("C:C,E:E,G:J,O:Z").EntireColumn.Delete

       With .Range("B2:B70")

          .Hyperlinks.Delete

          .HorizontalAlignment = xlCenter

          .VerticalAlignment = xlCenter

          .Font.Color = RGB(0, 0, 255)

          .Font.Name = "Times New Roman"

          .Font.Size = 10

       End With

       With .Range("A2:H70")

          For i = 7 To 12

             With .Borders(i)

                .LineStyle = xlContinuous

                .Color = -5658199

                .Weight = xlThin

             End With

          Next

          .Interior.Color = RGB(244, 176, 132)

          .Copy wshZ.Range("A80")

       End With

    End With

    End Sub

    War diese Antwort hilfreich?

    0 Kommentare
  3. Anonym
    2019-01-19T17:30:54+00:00

    Hallo Frank,

    vorher hattest du Pattern.Color zugewiesen und dann mit TintAndShade diese Farbe geändert (aufgehellt oder abgedunkelt), das verändert natürlich die RGB-Farbe.

    Zu deiner Frage:

    Dann kopiere nicht die Formate sondern nur die Werte und färbe dann die Zellen wieder blau ein:

    If Antw = vbOK Then

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

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

             Set dest = Sheets("Verkauft").Cells(Rows.Count, 1).End(xlUp)(2)

             dest.PasteSpecial xlPasteValues

             dest.Resize(1, 6).Interior.Color = RGB(0, 176, 240)

          Next

    Claus

    War diese Antwort hilfreich?

    0 Kommentare