das nachfolgende Makro funktioniert am Anfang sehr gut, das Tabellenblatt200 wird auch kopiert und bekommt einen neuen Namen. Doch dan kommt das Problem:die Daten des Neuen Blattes sollen in das Tabellenblatt200 der kopierten Datei (und nicht in die ursprüngliche Datei kopiert werden!!!!) was leiter geschiet. Wo liegt da das Problem?
Sub CopyActiveFile()
Dim wbAktiv As Workbook, vNewName As Variant, sInitialName As String
Set wbAktiv = ActiveWorkbook
'Vorgabe für neuen Namen generieren
sInitialName = "Neu " & Left(wbAktiv.Name, InStrRev(wbAktiv.Name, ".") - 1)
'Dialog zur Eingabe/Auswahl des Dateinamens anzeigen
vNewName = Application.GetSaveAsFilename(InitialFileName:=sInitialName, _
Filefilter:="Excel (*.xls;*.xlsx;*.xlsm;*.xlsb),*.xls;*.xlsx;*.xlsm;*.xlsb", _
Title:="Bitte neuen Dateinamen eingeben/auswählen")
If vNewName = False Then GoTo Beenden 'Dialog wurde abgebrochen
'Neuen Namen mit Name der aktiven Datei vergleichen
If UCase(wbAktiv.FullName) = UCase(vNewName) Then
MsgBox "Als neuer Name wurde der Name der aktiven Datei gewählt. " & vbLf _
& "Das ist nicht zulässig!", vbInformation + vbOKOnly
GoTo Beenden
End If
If Dir(vNewName) "" Then
If MsgBox("Eine Datei mit dem ausgewählten Namen existiert bereits. " & vbLf _
& "Datei """ & vNewName & """ überschreiben?", _
vbQuestion + vbOKCancel + vbDefaultButton2) = vbCancel Then
GoTo Beenden
End If
End If
'Kopie der Datei unter dem neuen Namen speichern
wbAktiv.SaveCopyAs Filename:=vNewName
'Kopie öffnen
Set wbAktiv = Workbooks.Open(Filename:=vNewName)
With wbAktiv
.Worksheets(200).Activate
Dim einGabe
einGabe = Application.InputBox("Bitte das Jahr eingeben, für das die Berechnung durchgefürt _
werden soll !!", "Eingabe", , , , , , 1)
If Not VarType(einGabe) = vbBoolean Then Range("A1") = einGabe
End With
Beenden:
Dim NeuerName As String, liSuche As Integer, lboShName As Boolean
Worksheets(200).Activate
Do Until lboShName = True
NeuerName = InputBox("Bitte geben Sie den neuen Namen des Blattes ein!")
If NeuerName = "" Then Exit Sub
lboShName = True
For liSuche = 1 To Sheets.Count
If LCase(NeuerName) = LCase(Sheets(liSuche).Name) Then
MsgBox "Blattname schon vorhanden"
lboShName = False
Exit For
End If
Next
Loop
ActiveWorkbook.ActiveSheet.Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = NeuerName
With ActiveSheet.UsedRange
.Value = .Value
Dim lngCol As Long
For lngCol = Columns("B:B").Column To Columns("O:O").Column Step 4
Tabelle200.Range(Tabelle200.Cells(1, lngCol), Tabelle200.Cells(49, lngCol)).Value = _
ActiveSheet. _
Range(ActiveSheet.Cells(1, lngCol + 1), ActiveSheet.Cells(49, lngCol + 1)).Value
Next
End With
End Sub
Gruß Werner