eigene xls aus einem Blatt erstellen
30.10.2019 15:38:38
EasyD
folgenden Code funktioniert grundsätzlich wie gewünscht, hat aber noch einen Schönheitsfehler.
Ich erstelle mir eine eigene Datei aus einem von 3 Blättern (2, 3 und 4) mit einem Select Case, welches davon abhängt was ich zuvor in die Zelle N2 des jeweiligen Blattes geschrieben habe. Wenn "manuell" dann Code ausführen.
Läuft wie gesagt auch, aber am Ende des Durchlaufes wird aber das falsche Blatt angezeigt.
Das Ziel ist, die Tabelle "1" am Ende anzuzeigen.
Wer kann mir sagen wo ich hänge?
Außerdem:
Ist es möglich, den Namen der Quelldatei nicht fix zu hinterlegen mit "Test_1.0.xlsm" sondern als Variable zu deklarieren damit es egal wird ob der Benutzer den Dateinamen ändert? Schließlich kann ich mich nicht einfach auf AktiveWorkbook beschränken, da durch die Erstellung der neuen Datei das aktive Workbook sich ja nun mal ändert....
Der Code:
Sub AnschrManuell()
'ein eigenes Excel-Sheet speichern für die manuelle Anfertigung eines Schreibens
Dim wbAkt As Workbook
Set wbAkt = Workbooks("Test_1.0.xlsm")
'''Dim wbAkt As String
'''wbAkt = ActiveWorkbook.Name
Application.ScreenUpdating = False
If MsgBox("Es wird eine gesonderte Version" & _
" erstellt zur manuellen Bearbeitung. Fortfahren?", _
vbOKCancel, "Manuell") = vbOK Then
Select Case "manuell"
Case Sheets("2").Range("N2").Value
Sheets("2").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
With ActiveWorkbook
.SaveAs Filename:=wbAkt.Path & "\2_manuell.xls", FileFormat:=xlNormal ' xlExcel8
.Close 'Neue Datei wird geschlossen
End With
MsgBox "Erledigt!" & Chr(13) & _
"Sie finden die Datei im angegebenen Verzeichnis.", vbOKOnly, "Fertig!"
Case Sheets("3").Range("N2").Value
Sheets("3").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
With ActiveWorkbook
.SaveAs Filename:=wbAkt.Path & "\3_manuell.xls", FileFormat:=xlNormal 'xlExcel8
.Close 'Neue Datei wird geschlossen
End With
MsgBox "Erledigt!" & Chr(13) & _
"Sie finden die Datei im angegebenen Verzeichnis.", vbOKOnly, "Fertig!"
Case Sheets("4").Range("N2").Value
Sheets("4").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
With ActiveWorkbook
.SaveAs Filename:=wbAkt.Path & "\4_manuell.xls", FileFormat:=xlNormal 'xlExcel8
.Close 'Neue Datei wird geschlossen
End With
MsgBox "Erledigt!" & Chr(13) & _
"Sie finden die Datei im angegebenen Verzeichnis.", vbOKOnly, "Fertig!"
End Select
Sheets("1").Activate
Else
Exit Sub
End If
Sheets("Datenerfassung").Activate
Application.ScreenUpdating = True
End Sub