Hallo Alex,
hier die geänderten Makros für Diene Exceldatei. Den Blattschutz muss ich bei einigen Aktionen temporär aufheben und danach wieder setzen. Im Moment hat der kein Passwort. Wenn jemand mal eins einträgt, würde der code wieder nicht laufen. Man müsste es dann im code fest programmieren - allerdings im Klartext. Wenn ein Makro, was den Blattschutz aufhebt, mal abbricht, dann ist das entsprechende Blatt ungeschützt und wird erst beim nächsten Makrodsurchlauf, wo der Blattschutz angefasst wird, wieder gesetzt.
in DieseArbeitsmappe
Code:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'Wenn der Name des aktiven Blattes <> Input und Sales ist, dann
If Sh.Name <> "Input" And Sh.Name <> "Sales" Then
'Wenn die Aenderung in Spalte G erfolgt und nur eine Spalte betrifft, dann
If Target.Row > 2 And Target.Column = 9 And Target.Columns.Count = 1 And Target.Areas.Count = 1 Then
'Blattschutz aufheben '<-- hier
Sh.Unprotect '<-- hier
'Schleife ueber alle gewaehlten Zellen
For Each zellen In Target
'Mit dem Bereich Spalte C (3) bis M (13)
With Sh.Range(Sh.Cells(zellen.Row, 3), Sh.Cells(zellen.Row, 13))
'Wenn Inhalt > 0 ist, dann mit ... einfaerben, sonst Farbe rausnehmen
If zellen > 0 And zellen.Offset(, -1) <> "" Then
.Interior.Color = 5296274
ElseIf zellen.Offset(, -1) <> "" Then
.Interior.Color = xlNone
'Hellgrau in Spalte I und K setzen '<-- hier
Sh.Cells(zellen.Row, 9).Interior.Color = 15921906 '<-- hier
Sh.Cells(zellen.Row, 11).Interior.Color = 15921906 '<-- hier
End If
'Ende Mit dem Bereich Spalte C (3) bis M (13)
End With
'Ende Schleife ueber alle gewaehlten Zellen
Next
'Blattschutz setzen '<-- hier
Sh.Protect '<-- hier
'Ende Wenn die Aenderung in Spalte G erfolgt und nur eine Spalte betrifft, dann
End If
'Ende Wenn der Name des aktiven Blattes <> Input und Sales ist, dann
End If
End Sub
im MOdul, Makro Kopieren diesen Teil ersetzen:
Code:
'Schleife ueber alle Blaetter
For Each myWsh In Worksheets
'mit dem Blatt myWsh
With myWsh
'Wenn der Blattname vom temporaeren Blatt <> vom Blatt myWsh ist, dann
If tmpWsh.Name <> myWsh.Name And myWsh.Name <> "Input" Then
'Blattschutz aufheben '<-- hier
.Unprotect '<-- hier
'Ueberschrift 1x kopieren
'wenn Zelle C19 auf temporaerem Blatt leer ist, dann
If tmpWsh.Cells(19, 3) = "" Then
'aus Zeile 2 kopieren
.Range("A2:M2").Copy
'in Zeile 19 auf temporaerem Blatt einfuegen, Bereich ggf. anpassen
tmpWsh.Paste tmpWsh.Range("A19")
'Ende wenn Zelle C18 leer ist, dann
End If
'Wenn die Summe von Spalte G > 0 ist, dann
If WorksheetFunction.Sum(.Range("G:G")) > 0 Then
'Spalte A und B einblenden
.Columns("A:B").EntireColumn.Hidden = False
'Autofilter in Spalte G setzen
.Columns("G:G").AutoFilter
'Spalte G filtern nach Werten > 0, Filter bis zur letzten gefuellten Zeile in Spalte G + 1
'Es darf in Spalte G also nix unter den Daten stehen.
.Range("$G$1:$G$" & .Cells(Rows.Count, 7).End(xlUp).Row).AutoFilter Field:=1, Criteria1:=">0"
'Tabellenname in temporaeres Blatt, Spalte C eintragen, letzte Zeile anhand Spalte G
tmpWsh.Range("C" & tmpWsh.Cells(Rows.Count, 7).End(xlUp).Row + 2) = myWsh.Name
'Zeile zum Einfuegen ermitteln, letzte Zeile anhand Spalte G + 2 (2 wegen Tabellennamen in Spalte C)
iPasteRow = tmpWsh.Cells(Rows.Count, 7).End(xlUp).Row + 3
'Bereich kopieren und in Tabelle2 einfuegen
.Rows("2:" & .Cells(Rows.Count, 7).End(xlUp).Row).Copy tmpWsh.Range("A" & iPasteRow)
'Zwischensumme
'Summenzelle
iSumRow = tmpWsh.Cells(Rows.Count, 5).End(xlUp).Row
'mit der Summenzelle
With tmpWsh.Range("J" & iSumRow + 1)
'Zwischensumme einfuegen
.Value = WorksheetFunction.Sum(Range("J" & iPasteRow & ":J" & iSumRow))
'Euroformat
.NumberFormat = "#,##0.00 $"
'Zwischensumme merken / kumulieren
sSum = sSum + .Value
'Ende mit der Summenzelle
End With
'Autofilter in Spalte G zuruecksetzen
.Columns("G:G").AutoFilter
'Spalte A und B ausblenden
.Columns("A:B").EntireColumn.Hidden = True
'Ende Wenn die Summe von Spalte G > 0 ist, dann
End If
'Blattschutz setzen '<-- hier
.Protect '<-- hier
'Ende Wenn der Blattname vom temporaeren Blatt <> vom Blatt myWsh ist, dann
End If
'Ende mit dem Blatt myWsh
End With
'Ende Schleife ueber alle Blaetter
Next
Ich habe dann noch am Ende vom cellReset die Zeilenzahl flexibel gemacht, wegen 2003:
Code:
'letzte belegte Zelle in Spalte G
loLastRow = WorksheetFunction.Max(blaetter.Cells(Rows.Count, 7).End(xlUp).Row, 3)
'Blatt SALES Spalte G ab G3 bereinigen
Sheets("Sales").Range("G3:G" & loLastRow).Value = ""
