Hallo Nejos,
nachfolgend Dein Makro so abgeändert, dass Du den Namen der zu kopierenden Blätter eingeben kannst.
Kopiere das Makro in ein StandardModul und starte es z.B. über eine Befehlsschaltfläche
Teste das Makro aber bitte in einer Testdatei und nicht gleich in Deiner Originaldatei.
Option Explicit
Public Sub CopyWks()
Dim wbMappe As Workbook
Dim strDruckarray()
Dim intMeldung As Integer
Dim wbMappe As Workbook
Dim intZähler As Integer
Dim strEingabe As String
Dim intSheetIndex As Integer
Dim bolSheetVorhanden As Boolean
Dim intSheets As Integer
On Error GoTo DispFehler
Application.DisplayAlerts = False
'------------------------------------------------------------------------------
intZähler = 1
ReDim strDruckarray(1 To intZähler)
Anfang:
'------------------------------------------------------------------------------
'Schritt 1: Eingabe des Blattnamen
strEingabe = InputBox("Bitte Blattname eintragen", Default:=strEingabe)
'------------------------------------------------------------------------------
'Schritt 2: Prüfen ob eingegebenes Tabellenblatt in Datei vorhanden ist
bolSheetVorhanden = False
For intSheetIndex = 1 To Sheets.Count
If Sheets(intSheetIndex).Name = strEingabe Then
bolSheetVorhanden = True
Exit For
End If
Next intSheetIndex
'------------------------------------------------------------------------------
'Schritt 3: Blattnamen in Array eintragen, wenn vorhanden, wenn nicht Bildschirmmeldung
If bolSheetVorhanden = True Then
strDruckarray(intZähler) = strEingabe
Else
MsgBox "Das angegebene Tabellenblatt existiert in dieser Datei nicht. Bitte " _
& "ändern Sie den Blattnamen.", vbCritical, "falsche Eingabe..."
GoTo Anfang
End If
'------------------------------------------------------------------------------
'Schritt 4: Abfrage, ob ein weiteres Tabellenblatt eingegeben werden soll
intMeldung = MsgBox("Sollen weitere Blattnamen eingetragen werden?", _
vbYesNo + vbQuestion, "Blattnameneingabe...")
If intMeldung = 6 Then
intZähler = intZähler + 1
ReDim Preserve strDruckarray(1 To intZähler)
GoTo Anfang
End If
'------------------------------------------------------------------------------
'Schritt 5: Blätter in neue Datei kopieren
Set wbMappe = Workbooks.Add
ThisWorkbook.Worksheets(strDruckarray).Copy
'------------------------------------------------------------------------------
'Schritt 6: Daten kopieren und nur Werte in Blatt zurückschreiben
For intSheets = 1 To wbMappe.Sheets.Count
wbMappe.Sheets(intSheets).Cells.Copy
wbMappe.Sheets(intSheets).Range("A1").PasteSpecial Paste:=xlPasteValues
Next
DispFehler:
wbMappe.SaveAs "C:\Temp\DeinName.xls"
wbMappe.Close
Application.DisplayAlerts = True
Set wbMappe = Nothing
End Subb
In Schritt 1 erfolgt die Eingabe des Blattnamens.
In Schritt 2 wird geprüft, ob der eingegebene Blattname in der Datei existiert.
Gibt es das Blatt, dann wird in Schritt 3 der eingegebene Blattname in ein Array geschrieben. Wenn nicht, erscheint eine Bildschirmmeldung, dass der Blattname geändert werden muss.
In Schritt 4 wird abgefragt, ob weitere Tabellenblattnamen eingegeben werden soll. Wenn ja, dann wird wieder mit Schritt 1 begonnen.
Schritt 5 kopiert alle angegebenen Tabellenblätter in eine neue Datei.
Bei Schritt 6 werden dann wieder alle Formeln gegen Werte ausgetauscht.
Ich hoffe, Du meintest das so?
MfG,
Oliver
[sub]Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du[/sub]
[sup] ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.[/sup]
