Werte auf neues Blatt mit Makro
03.09.2013 10:47:59
Fischer
ich habe ein Makro aufgeszeichnet bei dem eine Tabelle auf Blatt 1 in ein neues Blatt kopiert wird. Anschließend werden die Werte noch aus der ersten Tabelle gelöscht und das neue Blatt geschützt.
Problem: Das vorhergegangene Blatt wird irgendwie auch überschrieben und eine art Bild eingefügt. Schön wäre es noch wenn das neue Blatt immer das aktuelle Datum als Namen hat.
Vielen Dank füe eventuelle Hilfe.
Makro:
Sub t()
Dim letzteZeile As Long
letzteZeile = Range("A65536").End(xlUp).Row + 1
If letzteZeile
Sub nachdatum()
' nachdatum Makro
ActiveWindow.SmallScroll Down:=6
Range("A6:K32").Select
Range("K32").Activate
ActiveWorkbook.Worksheets("Tabelle1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Tabelle1").Sort.SortFields.Add Key:=Range("J6:J32" _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Tabelle1").Sort
.SetRange Range("A6:K32")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWindow.SmallScroll Down:=-12
End Sub
Sub datum2()
' datum2 Makro
ActiveWorkbook.Worksheets("Tabelle1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Tabelle1").Sort.SortFields.Add Key:=Range("J6:J32" _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Tabelle1").Sort
.SetRange Range("A6:K32")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWindow.SmallScroll Down:=-15
Range("M16").Select
End Sub
Sub fertig()
' fertig Makro
ActiveWindow.SmallScroll Down:=9
Range("A4:L33").Select
Range("L33").Activate
Selection.Copy
Sheets.Add After:=ActiveSheet
Range("A1").Select
ActiveSheet.CheckBoxes.Add(1161, 266.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 284.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 302.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 320.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 338.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 356.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 374.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 392.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 410.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 428.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 446.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 464.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 482.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 500.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 518.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 536.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 554.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 572.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 590.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 626.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 608.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 608.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 644.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 662.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 680.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 698.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 716.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 734.25, 31.5, 16.5).Select
ActiveSheet.Paste
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Columns("J:J").EntireColumn.AutoFit
Columns("L:L").EntireColumn.AutoFit
Range("M2").Select
Columns("K:K").EntireColumn.AutoFit
ActiveWindow.SmallScroll Down:=0
Sheets("Tabelle1").Select
ActiveWindow.SmallScroll Down:=-6
Range("A6:K33").Select
Range("K33").Activate
Application.CutCopyMode = False
Selection.ClearContents
ActiveWindow.SmallScroll Down:=-18
Range("J2").Select
End Sub
Sub Makro9()
' Makro9 Makro
ActiveWindow.SmallScroll Down:=6
Range("A4:L33").Select
Range("L33").Activate
Selection.Copy
Sheets.Add After:=ActiveSheet
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.CheckBoxes.Add(1161, 266.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 284.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 302.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 320.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 338.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 356.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 374.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 392.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 410.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 428.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 446.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 464.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 482.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 500.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 518.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 536.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 554.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 572.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 590.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 626.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 608.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 608.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 644.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 662.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 680.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 698.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 716.25, 31.5, 16.5).Select
ActiveSheet.CheckBoxes.Add(1161, 734.25, 31.5, 16.5).Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=3
Range("A3:K29").Select
Range("K29").Activate
Application.CutCopyMode = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Sheets("Tabelle1").Select
ActiveWindow.SmallScroll Down:=-12
Range("A6:K32").Select
Range("K32").Activate
Selection.ClearContents
ActiveWindow.SmallScroll Down:=-6
Range("J2").Select
Sheets("Tabelle9").Select
Range("A3").Select
End Sub