Zellen mit roter Schrift in anderes Blatt kopieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Burghard
zuerst mal ein frohes, erfolgreiches neues Jahr 2018 ....
Für die Aufgabe einfach das kleine Makro in ein Modulblatt kopieren, einen normalen Button anlegen
(kein AktiveX Element!!), dem Button das Makro zuweisen, Fertig!! - Eine Kleinigkeit noch:
Es gibt zwei Befehle: - einen von beiden bitte löschen!! - Kannst du selbst entscheiden!!
Tb1.Cells(z, 1).PasteSpecial xlPasteAll - der kopiert alles, auch die Schriftfarbe
Tb1.Cells(z, 1).PasteSpecial xlPasteValues - der kopiert nur die Werte, keine Formate oder Schrift!!
mfg Piet

Sub Daten_auflisten()
Dim j As Long, lzDt As Long
Dim Tb1 As Worksheet, z As Long
Set Tb1 = Worksheets("Tabelle1")
z = 2  '1.Zeile in Tabelle1
With Worksheets("Daten")
'LastZell in Daten suchen
lzDt = .Cells(Rows.Count, 1).End(xlUp).Row
'Schleife für alle Daten durchsuchen
For j = 1 To lzDt
If .Cells(j, 4).Resize(1, 5).Font.ColorIndex = 1 Then
Else  'rote Schriftfarbe in Zelle
.Cells(j, 4).Resize(1, 5).Copy
Tb1.Cells(z, 1).PasteSpecial xlPasteValues   'kopiert nur Werte
Tb1.Cells(z, 1).PasteSpecial xlPasteAll      'kopert auch Schriftfarbe
z = z + 1
End If
Next j
Application.CutCopyMode = False
End With
End Sub

Option Explicit Sub Farbe_Rot() Dim LoLetzte1 As Long Dim LoLetzte2 As Long Dim LoI As Long Dim LoJ As Long Dim BoFarbe As Boolean With Worksheets("Daten") LoLetzte1 = Worksheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 LoLetzte2 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row For LoI = 1 To LoLetzte2 BoFarbe = False For LoJ = 4 To 8 If Cells(LoI, LoJ).Font.Color 255 Then BoFarbe = True Exit For End If Next LoJ If BoFarbe = False Then .Range(.Cells(LoI, 4), Cells(LoI, 8)).Copy Worksheets("Tabelle1").Cells( _ LoLetzte1, 1) LoLetzte1 = LoLetzte1 + 1 End If Next LoI End With End Sub

Sub Daten_auflisten() Dim j As Long, lzDt As Long Dim Tb1 As Worksheet, z As Long Set Tb1 = Worksheets("Tabelle1") z = 2 '1.Zeile in Tabelle1 Application.ScreenUpdating = False With Worksheets("Daten") 'LastZell in Daten suchen lzDt = .Cells(Rows.Count, 4).End(xlUp).Row 'Schleife für alle Daten durchsuchen For j = 1 To lzDt If .Cells(j, 4).Font.Color = 255 Then .Cells(j, 4).Resize(1, 5).Copy Tb1.Cells(z, 1).PasteSpecial xlPasteAll 'kopiert auch Schriftfarbe z = z + 1 End If Next j Application.CutCopyMode = False End With Application.ScreenUpdating = True End Sub

Sub Farbe_Rot() Dim LoLetzte1 As Long Dim LoLetzte2 As Long Dim LoI As Long Dim LoJ As Long Dim BoFarbe As Boolean With Worksheets("Daten") LoLetzte1 = 1 LoLetzte2 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row .Range(.Cells(1, 4), .Cells(1, 8)).Copy _ Worksheets("Tabelle1").Cells(LoLetzte1, 1) LoLetzte1 = LoLetzte1 + 1 For LoI = 1 To LoLetzte2 BoFarbe = False For LoJ = 4 To 8 If .Cells(LoI, LoJ).Font.Color 255 Then BoFarbe = True Exit For End If Next LoJ If BoFarbe = False Then .Range(.Cells(LoI, 4), .Cells(LoI, 8)).Copy _ Worksheets("Tabelle1").Cells(LoLetzte1, 1) LoLetzte1 = LoLetzte1 + 1 End If Next LoI End With

Beliebteste Forumthreads (12 Monate)

Zellen mit roter Schrift in anderes Blatt kopieren

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

319 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zellen mit roter Schrift in anderes Blatt kopieren

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

319 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread