AW: Daten automatisch auf mehrere Tabellenbläter
15.09.2016 03:07:14
fcs
Hallo Flip,
nach etwas experimentieren zeigte sich, dass es am "einfachsten" funktioniert, wenn man bei Änderungen jeweils die kompletten Kursliste in die anderen Blätter kopiert, dabei aber jeweils vorher die vorhandenen Daten löscht.
Das Makro reagiert nicht auf Änderungen von Formatierungen.
Wenn du nur Formatierungen änderst, dann musst du anschließend noch eine Zelle im Listenbereich ändern (z.B. Taste F2 oder Doppelklick in Zelle und dann ENTER), um auch die Formatierungen in die anderen Blätter zu übertragen.
Änderungen an den Daten der Kurs können jetzt nicht mehr rückgägig gemacht werden. Vor umfangreichen änderungen an der Kursliste also immer erst die Datei speichern/sihern!
Gruß
Franz
'Ereignismakro im VBA-Editor der Datei unter "DieseArbeitsmappe" einfügen
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Zeile As Long, Spalte As Long, Zeile_L As Long
Dim Zeile_T As Long, Spalte_T1 As Long, Spalte_T2 As Long
Dim rngCopy As Range
Dim bolCopy As Boolean
Dim wks As Worksheet
Dim StatusCalc As Long
'Blatt prüfen, in dem geändert wurde
Select Case Sh.Name
Case "Feiertage", "Tab XYZ"
'aus diesen Blättern keine Änderungen in die anderen Blätter übertragen
Case Else
'Initialwerte von Variablen setzen
bolCopy = False
Set rngCopy = Nothing
'1. Zeile und 1. Spalte des geänderten Zellbereichs merken
Zeile = Target.Row
Spalte = Target.Column
'Vergleichswerte für die relevanten Zellbereiche setzen
Select Case Sh.Name
Case "Kurse Übersicht"
Zeile_T = 5
Spalte_T1 = 1
Spalte_T2 = 2
Case Else
Zeile_T = 5
Spalte_T1 = 37
Spalte_T2 = 38
End Select
'Prüfen, ob geänderte Zelle im relevanten Zellbereich liegt
If Zeile >= Zeile_T Then
If Spalte >= Spalte_T1 And Spalte = Zeile_T Then
'zu kopierenden Zellbereich setzen
Set rngCopy = .Range(.Cells(Zeile_T, Spalte_T1), _
.Cells(Zeile_L, Spalte_T2))
End If
End With
End If
End If
'Kopierstatus prüfen
If bolCopy = True Then
'Makrobremsen lösen
With Application
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
'Alle Tabellenblätter in der Arbeitsmappe abarbeiten
For Each wks In ActiveWorkbook.Worksheets
'Blattname prüfen
Select Case wks.Name
Case Sh.Name, "Feiertage", "Tab XYZ"
'in diese Blätter nicht kopieren
Case Else
'Werte für relevanten Datenbereich setzen
Select Case wks.Name
Case "Kurse Übersicht"
Zeile_T = 5
Spalte_T1 = 1
Spalte_T2 = 2
Case Else
Zeile_T = 5
Spalte_T1 = 37
Spalte_T2 = 38
End Select
With wks
'letzte Zeile mit Daten im relevanten Datenbereich ermitteln
Zeile_L = Application.WorksheetFunction.Max( _
.Cells(.Rows.Count, Spalte_T1).End(xlUp).Row, _
.Cells(.Rows.Count, Spalte_T2).End(xlUp).Row)
If Zeile_L >= Zeile_T Then
'vorhandene Daten und Formate im relevanten Bereich löschen
.Range(.Cells(Zeile_T, Spalte_T1), _
.Cells(Zeile_L, Spalte_T2)).Clear
End If
If Not rngCopy Is Nothing Then
'neue Daten in den relevanten bereich kopieren
rngCopy.Copy Destination:=wks.Cells(Zeile_T, Spalte_T1)
End If
End With
End Select
Next
'Makrobremsen wieder zurücksetzen
With Application
.Calculation = StatusCalc
.EnableEvents = True
.ScreenUpdating = True
End With
End If
End Select
End Sub