VBA Farbenaus Zelle in Zellenzeilen übernehmen

Guten Abend Claus -man hab ich geschwitzt, auf einmal wurden weniger DS übernommen - gesuchtgesucht - und gefunden - ich hatte einen Parameter vergessen umzubenennen - aber gefunden !! Zu Deinem Sub - er macht seine Arbeit und alle Daten kommen an wie gewünscht.

Kleine Frage noch Verschieben Unikat Blau - was muss geändert werden damit die Werte der Zeile "ohneTextumbruch" in die Zellen übernommen werden kann? Spart Platz auf dem Archiv Tabellenblatt!

Ansonsten vielen, vielen DANK

Gruß und schönen Abend --> Frank

If Antw = vbOK Then

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

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

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

dest.PasteSpecial xlPasteValues

dest.PasteSpecial xlPasteFormats

Next

Hallo Frank,

sorry, die Zeile mit Hyperlinks habe ich übersehen.

Probiere es dann so:

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("TabelleEinl.xlsx"): Set wshQ = wbkQ.Sheets("Fahrzeuge")

'Zielmappe und Zielblatt

Set wbkZ = ThisWorkbook: Set wshZ = wbkZ.Sheets("TabelleArbeit")
With wshQ

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

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

   .Range("E:E,O:P,R:U,X:Z").EntireColumn.Delete

   With .Range("B2:B200")

      .Hyperlinks.Delete

      .HorizontalAlignment = xlCenter

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

   End With

   With .Range("A2:P200")

      For i = 7 To 12

         With .Borders(i)

            .LineStyle = xlContinuous

            .Color = -5658199

            .Weight = xlThin

         End With

      Next

      With .Interior

         .PatternColorIndex = xlAutomatic

         .ThemeColor = xlThemeColorAccent2

         .TintAndShade = 0.399945066682943

      End With

      .Copy Destination:=wshZ.Range("A250")

   End With

End With

End Sub

Claus

Ich doch noch mal - hab mir ins Knie geschossen, soll heißen, Unikat gefunden Zell B wird rot markiert - toll - aber zu einem späteren Zeitpunkt wird das gesetzte durch Übernahme der Farbe von P nach A wieder überschrieben - dumm gelaufen.

Bekommt man eine Abfrage hinein gebastelt welche B nach Rot abfragt und die Zeile somit nicht mit farblos überschreibt?

Gruß Frank

Sub Farbe von Spalte P bis Spalte A der Zeile ?bernehmen

Dim LRow As Long

Dim rngC As Range

With ActiveSheet

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

For Each rngC In .Range("P1" & LRow)

If rngC.Interior.ColorIndex = xlNone Then

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

Else

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

End If

Next

End With

'End Sub

Hallo Frank,

für Zellen ohne Farbe probiere dann so:

Sub Unikate()

Dim rngC As Range

Dim LRow As Long
With ActiveSheet

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

   'Wenn du ?berschriften hast, fange erst in B2 an

   For Each rngC In .Range("B1:B" & LRow)

      If Application.CountIf(.Range("B:B"), rngC) = 1 _

         And rngC.Interior.ColorIndex = xlNone Then

            rngC.Interior.Color = vbRed

      End If

   Next

End With

End Sub

Claus

Hallo Claus - schon wieder ich!!

Zu diesem Thema noch ne Frage - Mir ist aufgefallen das meine Lieben Kollegen auch mal was vergessen zu markieren - soll heißen, es bleiben auch mal Unikate in Tabelle übrig welche nicht Blau markiert sind.

Kann man das suchen nach Unikaten in Spalte B ohne Farbe programmieren? Wenn solch eine Zeile Gefunden wird sollte Zelle B - Rot markiert werden.

Geht so was?

Frank