Wenn der code an der Stelle hängen bleibt, tue bitte mal eine Überwachung hinzufügen und dort blaetter.name eingeben. Poste mir dann bitte den Blattnamen.
Code:
'auf einem Blatt zusammenfassen
'_______________________________________________________
Sub Kopieren()
'Variablendeklarationen
'Objekte
Dim myWsh As Worksheet, tmpWsh As Worksheet, myRng As Range
'String
Dim strAddress As String, strFind As String
'Integer
Dim iCnt%, iPasteRow%, iSumRow%
'single
Dim sSum As Single
'temporäres Blatt hinzufügen. Beachte: In diesem Beispiel muss das Blatt
'manuell wieder geloescht werden!
Set tmpWsh = Worksheets.Add(before:=Sheets(1))
'Daten aus Input uebernehmen
With Sheets("Input")
Range("C7:D7").Value = .Range("A6:B6").Value
Cells(7, 4).NumberFormat = "0.00%" 'Formatierung in %
Range("C7:D7").Value = .Range("A6:B6").Value
Cells(8, 4) = .Cells(7, 2) 'Daten aus B7 nach E8
Cells(8, 5) = .Cells(7, 14) 'Daten aus N7 nach D8
Cells(9, 3) = .Cells(8, 1) 'Daten aus A8 nach C9
Cells(9, 4) = .Cells(8, 2) 'Daten aus B8 nach D9
Cells(15, 4) = .Cells(14, 2) 'Daten aus B14 nach D15
Cells(9, 5) = .Cells(8, 14) 'Daten aus N8 nach E9
Cells(14, 4) = .Cells(13, 2) 'Daten aus B13 nach D14
Range("D9:E9").NumberFormat = "m/d/yyyy" 'Datumsformat setzen
Range("C10:D12").Value = .Range("A9:B11").Value
Range("E10:E12").Value = .Range("N9:N11").Value
Range("C14:C15").Value = .Range("A13:A14").Value
Range("C16:D16").Value = .Range("A15:B15").Value
Range("E16:G16").Value = .Range("N15:P15").Value
Range("C17:G17").Value = .Range("C16:G16").Value
Range("C17:D17").Value = .Range("A16:B16").Value
Range("E17:G17").Value = .Range("N16:P16").Value
Cells(7, 6) = .Cells(6, 15) 'Daten aus O6 nach F7
Cells(7, 7) = .Cells(6, 16) 'Daten aus P6 nach G7
Cells(17, 8) = .Cells(17, 7) 'Daten aus G7 nach H7
Cells(17, 8) = .Cells(17, 7) 'In Spalte R (18) bearbeiter und in Spalte S (19) Datum & Zeit eintragen
.Cells(.Cells(Rows.Count, 19).End(xlUp).Row + 1, 19) = Application.UserName
.Cells(.Cells(Rows.Count, 19).End(xlUp).Row, 20) = Date + Time '-- Zellenbestimmung.
'In H2 Bearbeiter und in I2 Datum & Zeit eintragen
Cells(2, 8) = Application.UserName 'Namensstempel
Cells(2, 9) = Date + Time 'Datum und Uhrzeitstempel
'Bild kopieren und im aktiven Blatt in C1 einfuegen
.Shapes("Logo").Copy
ActiveSheet.Paste Range("C1")
'Ende Daten aus Input uebernehmen
End With
'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
.Unprotect
'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 I > 0 ist, dann
If WorksheetFunction.Sum(.Range("I:I")) > 0 Then
'Spalte A und B einblenden
.Columns("A:B").EntireColumn.Hidden = False
'Autofilter in Spalte G setzen
.Columns("I:I").AutoFilter
'Spalte I filtern nach Werten > 0, Filter bis zur letzten gefuellten Zeile in Spalte I + 1
'Es darf in Spalte I also nix unter den Daten stehen.
.Range("$I$1:$I$" & .Cells(Rows.Count, 9).End(xlUp).Row).AutoFilter Field:=1, Criteria1:=">0"
'Tabellenname in temporaeres Blatt, Spalte C eintragen, letzte Zeile anhand Spalte I
tmpWsh.Range("C" & tmpWsh.Cells(Rows.Count, 9).End(xlUp).Row + 2) = myWsh.Name
'Zeile zum Einfuegen ermitteln, letzte Zeile anhand Spalte I + 2 (2 wegen Tabellennamen in Spalte C)
iPasteRow = tmpWsh.Cells(Rows.Count, 9).End(xlUp).Row + 3
'Bereich kopieren und in Tabelle2 einfuegen
.Rows("2:" & .Cells(Rows.Count, 9).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("I:I").AutoFilter
'Spalte A und B ausblenden
.Columns("A:B").EntireColumn.Hidden = True
'Ende Wenn die Summe von Spalte I > 0 ist, dann
End If
'Blattschutz setzen
.Protect
'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
'temporaeres Blatt aktivieren
tmpWsh.Activate
'Blattschutz aufheben
tmpWsh.Unprotect
'Eventmakros verhindern
Application.EnableEvents = False
'Mit der zelle fuer die Gesamtsumme
With Cells(Cells(Rows.Count, 9).End(xlUp).Row + 2, 10)
'Gesamtsumme eintragen
.Value = sSum
'In Zelle links daneben "Summe" eintragen
.Offset(0, -1).Value = "approx. total amount"
'Euroformat
.NumberFormat = "#,##0.00 $"
'Fett
.Font.Bold = True
'Ende Mit der zelle fuer die Gesamtsumme
End With
'Spaltenbreite automatisch anpassen
Cells.EntireColumn.AutoFit
'Spalte A und B ausblenden
Columns("A:B").EntireColumn.Hidden = True
'Farben rausnehmen
Rows("19:3000").Interior.Color = xlNone '<-- hier Startzeile und eventuell Endzeile anpassen
'Eventmakros erlauben
Application.EnableEvents = True
End Sub
gewählte Graustufe zurück setzt?
