AW: In anderes Tabellenblatt kopieren
23.08.2018 22:55:29
Hans
Hallo
bitte probier mal diesen geaenderten Code aus. Er prüft auch ob das onts Blatt vorhanden ist. Viel Erfolg.
mfg Hans
Option Explicit '23.8.2018 für Herber Forum
Const SpAm = "N" 'End-Spalte in Anmeldung
Private Sub CmdTransfer_Click()
Dim lzAnm As Long, lzSht As Long
Dim Datum As String, Monat As String
Dim Test As Worksheet
With ThisWorkbook
'1. Datumszelle laden um Monat festzustellen
Datum = CStr(Format(CDate(.Sheets("Anmelden").Range("K18")), "dd,mmmm,yyyy"))
Monat = Mid(Datum, 4, 25)
Monat = CStr(Left(Monat, Len(Monat) - 5))
'On Error GoTo Fehler
Set Test = Worksheets(Monat)
'aktuelle LastCell in Anmeldung ermitteln (max 1000)
lzAnm = .Sheets("Anmelden").Cells(1000, 3).End(xlUp).Row
'aktuelle LastCell im aktuellen Monat ermitteln (+1 für Offset)
lzSht = .Sheets(Monat).Cells(Rows.Count, 3).End(xlUp).Row + 1
'aktuellen Anmelde Bereich kopieren
.Sheets("Anmelden").Range("A18:" & SpAm & lzAnm).Copy
'im aktuellen Monat unten anhaengen
.Sheets(Monat).Cells(lzSht, 1).PasteSpecial xlPasteAll
Application.CutCopyMode = False
'aktuellen Anmelde Bereich löschen
.Sheets("Anmelden").Range("A18:" & SpAm & lzAnm).ClearContents
'neue LastCell im aktuellen Monat ermitteln (-17 für Ende)
lzSht = .Sheets(Monat).Cells(Rows.Count, 3).End(xlUp).Row - 17
.Sheets(Monat).Cells(18, 1).Value = 1 'immer auf 1 setzen!
.Sheets(Monat).Cells(18, 1).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Stop:= _
lzSht
End With
Exit Sub
Fehler: MsgBox Datum & " dieses Monats-Blatt existiert nicht!"
End Sub
'Private Sub CmdTransfer_Click()
'Dim wbMappe As Workbook
'Dim Letzte As Long
'ThisWorkbook.Sheets("Anmelden").UsedRange.Copy
'Sheets("August").Select
'Cells(18, 3).End(xlDown).Offset(1, 0).Select
'ActiveSheet.Paste
'End Sub