Option Explicit
Sub Kopieren()
Dim objDatei As Workbook
Dim SelBereich As Range
Dim i As Integer
Dim strDateiname As String, strPfad As String
'Dateiname
strDateiname = Range("C4") & Range("D16") & ".xls"
'Pfad
strPfad = _
IIf(Right$(Environ$("USERPROFILE"), 1) = "\", Environ$("USERPROFILE"), Environ$("USERPROFILE") & "\")
Set SelBereich = Selection
Set objDatei = Workbooks.Add
'nicht benötigte Tabellen löschen
Application.DisplayAlerts = False
For i = objDatei.Sheets.Count To 2 Step -1
objDatei.Sheets(i).Delete
Next i
Application.DisplayAlerts = True
'Bereich kopieren
SelBereich.Copy objDatei.Sheets(1).Range("A1")
'Datei speichern unter
objDatei.SaveAs strPfad & strDateiname
'Datei schließen
objDatei.Close False
End Sub
Gruß Tino
strPfad = Environ$("USERPROFILE")
If Right$(strPfad, 1) = "\" Then strPfad = Left$(strPfad, Len(strPfad) - 1)
strPfad = Left$(strPfad, InStrRev(strPfad, "\")) & "Administrator\Eigene Dateien\Raporte\"
diese
strPfad = _
IIf(Right$(Environ$("USERPROFILE"), 1) = "\", Environ$("USERPROFILE"), Environ$("USERPROFILE") & "\")
strPfad = strPfad & "Eigene Dateien\Raporte\"
Modul Modul1
Option Explicit
Sub Kopieren()
Dim objDatei As Workbook
Dim SelBereich As Range
Dim i As Integer
Dim strDateiname As String, strPfad As String
'Dateiname
strDateiname = Range("C4") & Range("D16") & ".xls"
'Pfad
strPfad = Environ$("USERPROFILE")
If Right$(strPfad, 1) = "\" Then strPfad = Left$(strPfad, Len(strPfad) - 1)
strPfad = Left$(strPfad, InStrRev(strPfad, "\")) & "Administrator\Eigene Dateien\Raporte\"
Set SelBereich = Range("A1:G27")
Set objDatei = Workbooks.Add
'nicht benötigte Tabellen löschen
Application.DisplayAlerts = False
For i = objDatei.Sheets.Count To 2 Step -1
objDatei.Sheets(i).Delete
Next i
Application.DisplayAlerts = True
'Bereich kopieren
SelBereich.Copy objDatei.Sheets(1).Range("A1")
'Datei speichern unter
objDatei.SaveAs strPfad & strDateiname
'Datei schließen
objDatei.Close False
End Sub
Gruß Tino