Zellen überwachen und automatisch Inhalt und Forma

Hallo Zusammen,
mein Problem wurde in einer ähnlichen Form schon einige Beiträge weiter unten behandelt, aber nicht so gelöst, dass ich etwas damit anfangen kann.
Es geht um den automatischen Übertrag von mehreren Zellen samt ihrer Formatierungen auf mehrere andere Tabellenblätter in der gleichen Arbeitsmappe. Die Ausgangszellen befinden sich alle in "Tabelle1" und die Zielzellen sind in "Tabelle2", "Tabelle3" und "Tabelle4".
Als Anfang meiner Versuche wählte ich ein Makro, welches eine Zelle eines Tabellenblattes automatisch überwacht und dann sobald eine Änderung vorgenommen wird, den Namen eines anderen Tabellenblattes ändert.
Diese funktionierende Makro habe ich veruscht etwas zu verändern, aber ohne Erfolg. Als beispiel habe ich eine Mappe mit den 2 Makros angehängt.
https://www.herber.de/bbs/user/92969.xlsm
Die meisten meiner Exel-Probleme konnte ich durch suchen und lesen hier im Forum lösen, aber diesmal ohne Erfolg.
Vielen Dank für Euer Wissen und Eure Hilfe

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim rng As Range Dim i As Long Application.ScreenUpdating = False With ThisWorkbook Set rng = .Sheets("Tabelle1").Range("A5:A7") If Not Application.Intersect(rng, Target) Is Nothing Then rngKey.Copy For i = 2 To 4 .Sheets("Tabelle" & i).Range(rng.Address).PasteSpecial xlPasteValues .Sheets("Tabelle" & i).Range(rng.Address).PasteSpecial xlPasteFormats Next End If End With Set rng = Nothing Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim rng As Range Dim i As Long Dim vntWks As Variant vntWks = Array("Tabelle2", "Tabelle3", "Tabelle4") Application.ScreenUpdating = False With ThisWorkbook Set rng = .Sheets("Tabelle1").Range("A5:A7") If Not Application.Intersect(rng, Target) Is Nothing Then rng.Copy For i = 0 To UBound(vntWks) .Sheets(vntWks(i)).Range(rng.Address).PasteSpecial xlPasteValues .Sheets(vntWks(i)).Range(rng.Address).PasteSpecial xlPasteFormats Next End If End With Set rng = Nothing Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

Hallo Christian,
nun tut der Code genau das was ich mir vorstelle und so wie ich es brauche. Ich kann beliebige Tabellen hinzufügen oder wieder entfernen.
Das i-Tüpfelchen wäre noch, dass auf jeder Tabelle in die eine Kopie der Zellen eingefügt wird, die Markierung vom Kopieren aufgehoben wird.
Dazu habe ich am Ende noch für jede Tabelle 2 Zeilen Code eingefügt, der Fett markierte, bevor das Bildschirmupdate wieder eingeschaltet wird:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim i As Long
Dim vntWks As Variant
vntWks = Array("Tabelle2", "Tabelle3", "Tabelle4")
Application.ScreenUpdating = False
With ThisWorkbook
Set rng = .Sheets("Tabelle1").Range("A5:A7")
If Not Application.Intersect(rng, Target) Is Nothing Then
rng.Copy
For i = 0 To UBound(vntWks)
.Sheets(vntWks(i)).Range(rng.Address).PasteSpecial xlPasteValues
.Sheets(vntWks(i)).Range(rng.Address).PasteSpecial xlPasteFormats
Next
End If
End With
Set rng = Nothing
Application.CutCopyMode = False
Sheets("Tabelle2").Select
Range("A4").Select
Sheets("Tabelle3").Select
Range("A4").Select
Sheets("Tabelle4").Select
Range("A4").Select
Sheets("Tabelle1").Select
Range("A4").Select
Application.ScreenUpdating = True
End Sub

Der Plan war eigentlich, einmal jede Tabelle und eine Zelle darin aus zu wählen und somit die Markierung vom kopieren zu entfernen.
Nun bekomme ich leider den Laufzeitfehler 1004: Die Select-Methode des Range-Objektes konnte nicht ausgeführt werden.
Auf jeden Fall danke ich dir schon vielmals bis hierher für deine Hilfe. Vielleicht kannst du mir dabei auch den entscheidenden Tipp geben.
Gruß
Tilo

With ThisWorkbook Set rng = .Sheets("Tabelle1").Range("A5:A7") If Not Application.Intersect(rng, Target) Is Nothing Then rng.Copy For i = 0 To UBound(vntWks) .Sheets(vntWks(i)).Range(rng.Address).PasteSpecial xlPasteValues .Sheets(vntWks(i)).Range(rng.Address).PasteSpecial xlPasteFormats .Sheets(vntWks(i)).Activate .Sheets(vntWks(i)).Cells(4, 1).Select Next End If .Sheets("Tabelle1").Activate .Sheets("Tabelle1").Cells(4, 1).Select End With

Beliebteste Forumthreads (12 Monate)

Zellen überwachen und automatisch Inhalt und Forma

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zellen überwachen und automatisch Inhalt und Forma

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread