von Tino habe ich vor kurzem untenstehenden Code erhalten. Funktioniert tip top. Nun habe ich aber einen individuellen Pfad nähmlich: I:\Rapporte\Gedruckt Wie muss ich nun diesen Pfad in den Code einfügen? Vielen Dank für die Hilfe,
Roger
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
Option Explicit
Sub Kopieren()
Dim objDatei As Workbook
Dim SelBereich As Range
Dim i As Integer
Dim strDateiname As String
'hier Pfad angeben, beachte abschließen mit \
Const strPfad As String = "I:\Rapporte\Gedruckt\"
'Dateiname
strDateiname = Range("C4") & Range("D16") & ".xls"
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