Makrofehler
Werner
das nachfolgende Makro fuktioniert soweit ganz gut bis auf einen Fehler auf den ich aber leiter nicht komme.
1. Die Datei wirt kopiert
2. Das Tabellenblatt wird kopiert
3. Die gewünschten Daten werden zwar kopiert, aber nicht in das Blatt 200 der kopierten Datei in der ich
mich befinde sondern in das Blatt 200 der Ursprüngliche Datei.
Wo liegt da der Fehler ?
über eine Lösung würde ich mich sehr freuen!
Gruß Werner
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)
'Blatt 1 aktivieren und Namen in B1 eintragen
With wbAktiv
.Worksheets(200).Activate
Dim einGabe
einGabe = Application.InputBox("Bitte Zahl eingeben", "Eingabe", , , , , , 1)
If Not VarType(einGabe) = vbBoolean Then Range("A1") = einGabe
'End Sub
' .Worksheets(1).Range("B1") = .FullName 'name inkl. Pfad
' .Worksheets(1).Range("B1") = .Name 'nur Dateiname
'.Save
End With
Beenden:
End Sub
Sub BlattKopieren()
Dim NeuerName As String, liSuche As Integer, lboShName As Boolean
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)
'Sheets ("Eingabe") .Copy After:=Sheets(i)
ActiveSheet.Name = NeuerName
With ActiveSheet.UsedRange
.Value = .Value
End With
End Sub
Sub DatenKopieren()
Dim lngCol As Long
For lngCol = Columns("B:B").Column To Columns("N:N").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 Sub