Makro startet nicht automatisch
23.08.2025 16:55:46
Christian
ich hab ein Makro versucht zu schreiben, das folgendes macht,
jeweils im Blatt "Auswertung"
bei Eingabe in Spalten C, D, F, G, I, J → automatisch formatieren (zentriert, kursiv, Schriftfarbe aus A).
bei Eingabe in Spalten D und G → automatisch als Datum TT.MM.JJJJ formatieren.
bei Eingabe in Spalte G → Differenz zu Spalte D in Jahren in H.
bei Eingabe in Spalte F → Zählen aller belegten Zellen (bis Zeile L1), Meldung wenn durch 1000 teilbar.
Aber warum tut sich nichts, alle Inhalte die ich in die 5 Spalten einfüge werden aus dem Internet kopiert und eingefügt, nicht eingetippt.
Danke
Christian
Hier noch das Makro:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim ws As Worksheet
Dim lastRow As Long
Dim arrA As Variant
Dim arrD As Variant
Dim arrF As Variant
Dim c As Range
Dim countF As Long
Dim i As Long
On Error GoTo Ende
' Nur auf Blatt "Auswertung" reagieren
If Sh.Name > "Auswertung" Then Exit Sub
Set ws = Sh
' Performance optimieren
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' Zeilenanzahl aus L1
lastRow = ws.Range("L1").Value
If lastRow 1 Then GoTo Ende
' Arrays vorbereiten
arrA = ws.Range("A1:A" & lastRow).Value
arrD = ws.Range("D1:D" & lastRow).Value
arrF = ws.Range("F1:F" & lastRow).Value
' Alle geänderten Zellen prüfen
For Each c In Target
If c.Row = lastRow Then
' ---- C, D, F, G, I, J ----
If c.Column = 3 Or c.Column = 4 Or c.Column = 6 Or _
c.Column = 7 Or c.Column = 9 Or c.Column = 10 Then
' Grundformatierungen
With ws.Cells(c.Row, c.Column)
.HorizontalAlignment = xlCenter
.Font.Italic = True
.Font.Color = arrA(c.Row, 1)
End With
End If
' ---- D oder G → Datum umwandeln ----
If c.Column = 4 Or c.Column = 7 Then
If IsDate(ws.Cells(c.Row, c.Column).Value) Then
ws.Cells(c.Row, c.Column).NumberFormat = "dd.mm.yyyy"
End If
End If
' ---- G geändert → Differenz in H ----
If c.Column = 7 Then
If IsDate(arrD(c.Row, 1)) And IsDate(ws.Cells(c.Row, 7).Value) Then
ws.Cells(c.Row, 8).Value = DateDiff("yyyy", arrD(c.Row, 1), ws.Cells(c.Row, 7).Value)
With ws.Cells(c.Row, 8)
.HorizontalAlignment = xlCenter
.Font.Italic = True
.Font.Color = arrA(c.Row, 1)
End With
Else
ws.Cells(c.Row, 8).ClearContents
End If
End If
' ---- F geändert → zählen ----
If c.Column = 6 Then
countF = 0
For i = 1 To UBound(arrF, 1)
If Len(arrF(i, 1)) > 0 Then countF = countF + 1
Next i
If countF > 0 And countF Mod 1000 = 0 Then
MsgBox "Es gibt jetzt " & countF & " Einträge in Spalte F.", vbInformation
End If
End If
End If
Next c
Ende:
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End SubHier die Bsp Datei
https://www.herber.de/bbs/user/178728.xlsm
Ihr könnt ja mal testweise etwas in die genannten Spalten eingeben. Einiges funktioniert, anderes auch nicht.
Fügt z.b. mal einen Text aus dem Internet kopiert in C3 ein und schaut ob die Schriftfarbe Rot aus A3 übernommen wird.
Oder kopiert ein Datum aus dem Internet im Format TT.MM.JJJ nach D3 und schaut, ob es in TT.MM.JJJJ umgewandelt wird.
Wie würde ein vollständiges funktionierendes Makro aussehen dass meine Wünsche erfüllt?
Danke
Christian
Anzeige