bestimmter Inhalt anhand der Farbe kopieren

Forumthread: bestimmter Inhalt anhand der Farbe kopieren

31.05.2014 14:37:34

Eddie

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

AW: bestimmter Inhalt anhand der Farbe kopieren

02.06.2014 09:02:55

UweD

Hallo Eddie
so...

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

Gruß UweD

@Uwe - kleiner Bugfix und es ist perfekt ....

02.06.2014 10:42:14

Eddie

Hallo Uwe,
erstmal VIELEN Dank ..es funktioniert leider noch nicht 100%ig, da die hellblauen Zeilen nicht mitkopiert werden.
Wie wird denn der Wert für denn Interior.Color = 15652540 gebildet ?
Ich hatte mich auf http://dmcritchie.mvps.org/excel/colors.htm mal eingelesen, aber nicht auf Anhieb die Lösung dafür gefunden.
Ich würde mich auf eine Antwort freuen.
Gruß
Eddie

AW: @Uwe - kleiner Bugfix und es ist perfekt ....

02.06.2014 10:48:03

UweD

Hallo nochmal
Bei mir werden Alle richtig kopiert.
- - -
Ich hab die Werte durch Aufzeichnen eines Makros abgelesen
- Füllung rausgenommen,
- Aufzeichnung gestartet,
- Zurückgesetzt auf die Originalfarbe
- Aufzeichnung gestoppt,
- Wert im Makro abgelesen
Gruß UweD

AW: @Uwe - kleiner Bugfix und es ist perfekt ....

02.06.2014 10:58:21

Eddie

Wenn ich das bei mir mache bekomme ich das Makro:

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

Gruß
Eddie

AW: @Uwe - kleiner Bugfix und es ist perfekt ....

02.06.2014 11:58:46

UweD

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

DANKESCHÖN

02.06.2014 12:15:43

Eddie

.... jetzt klappt es SUPER .. vielen DANK noch einmal für die Liebe Hilfe
Gruß´
Eddie

Beliebteste Forumthreads (12 Monate)

bestimmter Inhalt anhand der Farbe kopieren

Forumthread: bestimmter Inhalt anhand der Farbe kopieren

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

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread