Zellen mit Makro mitkopieren
22.08.2005 20:23:24
Heinz
Habe vom Herber Forum untenstehendes Makro bekommen.,läuft super.
Jetzt möchte ich aber eine Änderung vornehmen.
Nähmlich wenn ich ein Tab.Blatt kopiere sollte es die Werte vom Tab.Blatt "Legende"Zelle D19 bis D23 ins kopierte Tab.Blatt auf Zelle C6 bis C10 mitübernommen werden.Also jedesmal wenn ich ein neues Tab.Blatt erstelle sollten diese Werte drinnenstehen.
Könnte mir dabei Bitte jemand helfen!!
Danke & gruss Heinz
Sub kopiereBlatt()
Dim quellwks As Worksheet
Dim zielwks As Worksheet
Set quellwks = Sheets(Sheets.Count - 1)
Application.ScreenUpdating = False
quellwks.Unprotect "Test"
quellwks.Copy Before:=Sheets(Sheets.Count)
quellwks.Protect "Schöny"
'activesheet ist jetzt die kopie !!
Set zielwks = ActiveSheet
Dim wks As Worksheet
Dim zi, JUrl, ETDat, EinfDatE, EinfDatB As Variant
With zielwks
'.Name = .Range("A6") & " bis " & .Range("A52")
.Range("A6") = .Range("A52") + 3
.Range("M58:M60") = .Range("O58:O60").Value
'Berechnung für Urlaub
ETDat = Sheets("Legende").Range("D3").Value
EinfDatB = .Range("A6").Value - 2
EinfDatE = .Range("A52").Value
For zi = 1 To 500
ETDat = DateSerial(Year(ETDat) + 1, Month(ETDat), Day(ETDat))
If ETDat >= EinfDatB And ETDat <= EinfDatE Then
JUrl = Sheets("Legende").Range("H24").Value * 5
.Range("M58").Value = .Range("M58").Value + JUrl
End If
Next zi
'Ende eingefügt von Stephan(HerberForum)
.Range("J5") = .Range("J55").Value
Application.EnableEvents = False
.Range("C6:C10,C12:C16,C18:C22,C24:C28").ClearContents
.Range("C30:C34,C36:C40,C42:C46,C48:C52").ClearContents
.Range("F6:F10,F12:F16,F18:F22,F24:F28").ClearContents
.Range("F30:F34,F36:F40,F42:F46,F48:F52").ClearContents
.Range("L6:O10,L12:O16,L18:O22,L24:O28,L30:O34,L36:O40,L42:O46,L48:O52").ClearContents
End With
ActiveWindow.ScrollColumn = 1
Application.EnableEvents = True
Application.ScreenUpdating = True
zielwks.Protect "Test"
End Sub