Zellenfarbe übertragen

Guten Morgen,
ich habe eine Tabelle mit eingefärbten Zellen. Die Zellenfarben (A1:D10) sollen in ein anderes Feld (gleiches Tabellenblatt oder ein anderes) übertragen werden.
Ich habe den Befehl mit dem makrorecorder aufgenommen, möchte aber gerne eine elegante Lösung umsetzen.
Ich habe versucht das Makro abzuändern und den Code einem Tabellenblatt zuzuordnen, als private sub. Leider läuft das Makro nicht, die Zellenfarben werden nicht übernommen?
Könnt Ihr mir einen Lösungsvorschlag nennen?
Ich habe folgendes Makro versucht:


private sub fuellfarben()
application.enable.event=false
worksheets("Tabelle1").range(A1:A10").format = worksheets("Tabelle1").range("F1:F10").format
application.enable.event=true
end sub

Beispieldatei:
https://www.herber.de/bbs/user/105649.xlsm

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim rngBereich As Range Dim rngArea As Range Dim rngZelle As Range Set rngBereich = Intersect(Target, Range("A:D")) If Not rngBereich Is Nothing Then For Each rngArea In rngBereich.Areas For Each rngZelle In rngArea rngZelle.Offset(0, 5).Resize(1, 1).Interior.Color = rngZelle.Interior.Color Next rngZelle Next rngArea End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim rngBereich As Range Dim rngArea As Range Dim rngZelle As Range Set rngBereich = Intersect(Target, Range("A1:D10")) MsgBox "rngBereich: " & rngBereich.Address & vbLf & _ "Target: " & Target.Address & vbLf & _ "Selection: " & Selection.Address If Not rngBereich Is Nothing Then For Each rngArea In rngBereich.Areas For Each rngZelle In rngArea Sheets(2).Range(rngZelle.Address).Interior.Color = rngZelle.Interior.Color Next rngZelle Next End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim rngBereich As Range Dim rngZelle As Range Set rngBereich = Intersect(Target, Range("A1:D10")) If Not rngBereich Is Nothing Then If Target(1).Value = 1 Then Set rngBereich = Range("A1:D10") 'alles, wenn 1 If rngBereich.Columns.Count = 1 Then Sheets(2).Range(rngBereich.Address).Interior.Color = rngBereich.Interior.Color Else For Each rngZelle In rngBereich Sheets(2).Range(rngZelle.Address).Interior.Color = rngZelle.Interior.Color Next rngZelle End If End If End Sub

Hi Markus,
ich habe Dein Makro leicht abgeändert.
Der springende Punkt war, daß das Event zum Übertragen der Farbe in dem Moment ausgelöst wird, wo ein Wert in die Zelle geschrieben wird - die Farbe hattest Du aber erst NACH Auslösung des Events gesetzt.
Die Zeilen zur "Geschwindigkeitssteigerung" habe ich auskommentiert: bei 10 Werten braucht's das nicht, vielleicht bei ein paar 100 oder 1000.
Das geänderte Makro lautet:

Sub transfer()
Dim zeile As Long
' Application.Calculation = xlCalculationManual
' 'Screenupdate
' Application.ScreenUpdating = False
'For/Next-Schleife start
For zeile = 2 To 10
' zuerst Farbe setzen...
If Worksheets("Tabelle3").Cells(zeile, 3) Like "*blau*" Then
Worksheets("Tabelle1").Cells(zeile - 1, 1).Interior.ColorIndex = 33
End If
' dann Werte schreiben bzw. kopieren
Worksheets("Tabelle3").Cells(zeile, 2).Copy
Worksheets("Tabelle1").Cells(zeile - 1, 1).PasteSpecial Paste:=xlPasteValues
Next zeile
' Application.Calculation = xlCalculationAutomatic
' 'Screenupdate
' Application.ScreenUpdating = True
End Sub

Auf das ganze "Event" bzw. die Sub Worksheet_Change in Tabelle1 kannst Du verzichten, indem Du das so formulierst (vor dem Test bitte die worksheet_change umbenennen, damit sie nicht mehr ausgelöst wird):

Sub transfer()
Dim zeile As Long
For zeile = 2 To 10
If Worksheets("Tabelle3").Cells(zeile, 3) Like "*blau*" Then
Worksheets("Tabelle1").Cells(zeile - 1, 1).Interior.ColorIndex = 33
' hier gleich die Farbe in Tabelle2 gesetzt
Worksheets("Tabelle2").Cells(zeile - 1, 1).Interior.ColorIndex = 33
End If
' hier einfache Wertzuweisung, nur um es Dir zu zeigen
Worksheets("Tabelle1").Cells(zeile - 1, 1) = Worksheets("Tabelle3").Cells(zeile, 2)
Next zeile
End Sub

Übrigens kannst Du solche Logik-Sachen leicht selbst finden, indem Du ein Makro zeilenweise mit F8 durchgehst und dabei beobachtest, was passiert.
Schöne Grüße,
Michael

Beliebteste Forumthreads (12 Monate)

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread