bestimmter Inhalt anhand der Farbe kopieren

Hallo,
ich würde gerne von einer bestehenden Tabelle nur ein bestimmten Teil Als Auswertung auf ein neues Tabellenblatt kopieren.
Es sollen von Tabelle 1 bestimmte Daten auf ein neues/bestehendes Tabellenblatt kopiert wrden.
Wenn in Spalte B ein Feld blau (es gibt 2 versch.) oder keine Farbe hat, dann soll von dieser Zeile der Inhalt von der Spalte B,C und F in das neue Blatt kopiert werden.
Wenn in der Spalte B eine andere Farbe ist soll der Inhalt nicht auf der "Auswertungsseite) zu sehen sein.
Leider reichen meine Programmierkenntnisse nicht aus um dieses zu lösen.
Im Anhang habe ich die Beispieltabelle eingefügt.
Vielen Dank schon einmal und allen ein schönes Wochenende
https://www.herber.de/bbs/user/90930.xlsx
Gruß
Eddie

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Farbe() On Error GoTo Fehler Dim TB1, TB2, SP%, ZE&, LR1&, LR2& Dim i&, stCalc% '*** bescheunigt das Makro With Application .ScreenUpdating = False stCalc = .Calculation .Calculation = xlCalculationManual End With '*** Stammdaten Anfang Set TB1 = Sheets("Tabelle1") Set TB2 = Sheets("Auswertung") SP = 2 'Spalte B ZE = 4 'ab Zeile '*** Stammdaten Ende LR1 = TB1.Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte '*** Die eigentliche Routine With TB1 TB2.Range("A:C").Clear Range("A2").Formula = "Nummer" Range("B2").Formula = "Info" Range("C2").Formula = "Wichtig" For i = ZE To LR1 If .Cells(i, SP).Interior.Color = 15652540 Or _ .Cells(i, SP).Interior.Color = 13998939 Or _ .Cells(i, SP).Interior.Pattern = xlNone Then ' Hellblau /Dunkelblau/Keine LR2 = TB2.Cells(Rows.Count, 1).End(xlUp).Row + 1 .Range("B" & i & ":C" & i).Copy TB2.Cells(LR2, 1) .Range("F" & i).Copy TB2.Cells(LR2, 3) End If Next End With '*** Fehlerbehandlung Err.Clear Fehler: If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err. _ Clear '*** Rücksetzen With Application .ScreenUpdating = True If .Calculation stCalc Then .Calculation = stCalc End With End Sub

Sub Makro2() ' Makro2 Makro With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent1 .TintAndShade = 0.599993896298105 .PatternTintAndShade = 0 End With End Sub

Hallo
dann über ColorIndex...
Zelle markieren
über das kleine Makro wird dann die Farbe ausgelesen

Sub Farbe_lesen()
MsgBox "Index= " & Selection.Interior.ColorIndex
End Sub

Den Index dann hier entsprechend eintragen

Sub Farbe()
On Error GoTo Fehler
Dim TB1, TB2, SP%, ZE&, LR1&, LR2&
Dim i&, stCalc%
'*** bescheunigt das Makro
With Application
.ScreenUpdating = False
stCalc = .Calculation
.Calculation = xlCalculationManual
End With
'*** Stammdaten Anfang
Set TB1 = Sheets("Tabelle1")
Set TB2 = Sheets("Auswertung")
SP = 2 'Spalte B
ZE = 4 'ab Zeile
'*** Stammdaten Ende
LR1 = TB1.Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
'*** Die eigentliche Routine
With TB1
TB2.Range("A:C").Clear
Range("A2").Formula = "Nummer"
Range("B2").Formula = "Info"
Range("C2").Formula = "Wichtig"
For i = ZE To LR1
If .Cells(i, SP).Interior.ColorIndex = 24 Or _
.Cells(i, SP).Interior.ColorIndex = 42 Or _
.Cells(i, SP).Interior.ColorIndex = -4142 Then    ' Hellblau /Dunkelblau/ _
Keine
LR2 = TB2.Cells(Rows.Count, 1).End(xlUp).Row + 1
.Range("B" & i & ":C" & i).Copy TB2.Cells(LR2, 1)
.Range("F" & i).Copy TB2.Cells(LR2, 3)
End If
Next
End With
'*** Fehlerbehandlung
Err.Clear
Fehler:
If Err.Number  0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err. _
_
Clear
'*** Rücksetzen
With Application
.ScreenUpdating = True
If .Calculation  stCalc Then .Calculation = stCalc
End With
End Sub

Gruß UweD

Beliebteste Forumthreads (12 Monate)

bestimmter Inhalt anhand der Farbe kopieren

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread