Blatt Kopieren

Hallo Excelanier,
ich habe beim suchen einer Problemlösung folgendes gefunden:

Sub KopiereBlatt()
ThisWorkbook.Sheets("Namen").Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\test.xls"
ActiveWorkbook.Close 'falls gewünscht
End Sub

Das haut soweit auch hin.
Nun aber meine Frage, ich möchte die Zeile "ThisWorkbook.Sheets("Namen").Copy" gerne so ändern das egal wie die Tabelle heißt immer das Blatt 5 kopiert wird.
Die Zeile ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\test.xls" sollte so geändert werden, das die neue Datei den Namen des zukopierenden Blattes hat, allerdings soll der Dateiname immer vorweg den Begriff "Liste" stehen haben.
Beispiel: Das zu kopierende Blatt heißt Dosenbrot, Erwin". Die neue Datei soll dann Liste Dosenbrot, Erwin.xls heißen.
Kann mir bitte jemand helfen?
Gruss
Stefan

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub KopiereBlatt() Dim strFile As String 'Pfad strFile = IIf(Right(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\") With Application .ScreenUpdating = False 'Bildschirmaktualisierung aus .DisplayAlerts = False 'Meldungen aus With ThisWorkbook.Sheets(5) '5. Tabelle strFile = strFile & "Liste " & .Name & ".xls" 'Pfad + Dateiname .Copy 'kopieren End With With ActiveWorkbook .SaveAs Filename:=strFile 'speichern .Close False 'falls gewünscht End With .ScreenUpdating = True .DisplayAlerts = True End With End Sub

Option Explicit Sub KopiereBlatt() Dim strNam As String strNam = "\Liste " & Sheets(5).Name & ".xls" ThisWorkbook.Sheets(5).Copy With ActiveWorkbook .SaveAs Filename:=ThisWorkbook.Path & strNam .Close 'falls gewünscht End With End Sub

Hallo,
ist der Ordner nicht vorhanden wird er angelegt.
Laufwerk muss aber vorhanden sein und Du musst Dich zwischen Laufwerk E und D entscheiden.

Option Explicit
Private Declare Function apiCreateFullPath _
Lib "imagehlp.dll" Alias "MakeSureDirectoryPathExists" (ByVal lpPath As String) As Long

Sub KopiereBlatt()
Dim strFile As String
Dim lngPath As Long

'Pfad abschließen mit \ am Ende 
strFile = "D:\Test\NocheinTest\"
lngPath = apiCreateFullPath(strFile) 'Ordner anlegen, wenn ich vorhanden 

If lngPath = 1 Then
    With Application
     .ScreenUpdating = False 'Bildschirmaktualisierung aus 
     .DisplayAlerts = False 'Meldungen aus 
        
        With ThisWorkbook.Sheets(5) '5. Tabelle 
         strFile = strFile & "Liste " & .Name & ".xls" 'Pfad + Dateiname 
         .Copy 'kopieren 
        End With
        
        With ActiveWorkbook
         .SaveAs Filename:=strFile 'speichern 
         .Close False 'falls gewünscht 
        End With
     
     .ScreenUpdating = True
     .DisplayAlerts = True
    End With
Else
 MsgBox "Ordner konnte nicht gefunden oder angelegt werden!"
End If

End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread