Speichern mit Unterordner aus Zelle

Sub SpeichernUnter() ThisWorkbook.Worksheets("Firma").Activate Const stdPath = "h:/bewatec/" Dim myPath As String myPath = Range("b1") MsgBox ThisWorkbook.Name ThisWorkbook.SaveAs Filename:=stdPath & "/" & myPath & "/" & "Wartung2011.xlsm" End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub SpeichernUnter() ThisWorkbook.Worksheets("Firma").Activate Const stdPath = "h:\bewatec\" Dim myPath As String myPath = Range("b1") MsgBox ThisWorkbook.Name ThisWorkbook.SaveAs Filename:=stdPath & myPath & "\" & "Wartung2011.xlsm" End Sub

Sub SpeichernUnter() ThisWorkbook.ActiveSheet.Activate ThisWorkbook.Worksheets("Firma").Activate Const stdPath = "h:\bewatec\" Dim myPath As String myPath = Range("b1") Dim Verzeichnis As String, fso As Object Set fso = CreateObject("Scripting.Filesystemobject") Verzeichnis = stdPath & myPath If fso.FolderExists(Verzeichnis) = False Then MkDir Verzeichnis MsgBox ThisWorkbook.Name ThisWorkbook.SaveAs Filename:=stdPath & myPath & "\" & myPath & "_Wartung2011.xlsm" 'Application.Dialogs(xlDialogSaveAs).Show End Sub

Hallo Oli,
zu deinem Code. Schreib die Dim Anweisungen zuoberst in den Code, die werden nämlich immer zuerst ausgeführt und zwar alle, auch dieses Dim:
If Weihnachten=Ostern
Dim A as Integer
End If.
Grund ist, beim makrostart kompiliert Vba manche Dinge, wie z.B. die variablen um ihnen den nötigen Speicher-Platz zuzuweisen.
Anschließend interpretiert Vba nur noch den Code.
Was soll das sein:
ThisWorkbook.ActiveSheet.Activate
Du aktivierst das sowieso aktivierte Blatt nochmals?
ThisWorkbook.ActiveSheet.Activate
ThisWorkbook.Worksheets("Firma").Activate
Wenn du mehrfach hintereinander aktivierst kannst du alle Aktivierungen bis auf die letzte "vergessen".
ThisWorkbook.Worksheets("Firma").Activate
ergibt das Gleiche.
Du benutzt MkDir, das verlangt daß der Pfad zum anzulegenden Verzeichnis vorher existiert.
Ich weiß aber, entweder mit FSO oder API kann man auch sowas schreiben im Pseudocode:
Erstelle c:\ordner1\ordner2\ordner3
D.h. das Verzeichnis wird auch erstellt wenn z.B. c:\ordner1 noch gar nicht existiert.
Was ich nun leider nicht weiß was man anstelle von "Erstelle" coden muß :-(
Gruß
Reinhard

' ********************************************************************** ' Modul: Modul2 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long Sub SpeichernUnter() Dim strFilePath As String Const cstrStdPath = "h:\bewatec\" With ThisWorkbook With .Worksheets("Firma") strFilePath = cstrStdPath & IIf(Right(cstrStdPath, 1) = "\", "", "\") & _ .Range("B1") & IIf(Right(.Range("B1"), 1) = "\", "", "\") & "_Wartung2011.xlsm" End With If MakeSureDirectoryPathExists(strFilePath) <> 0 Then .SaveAs strFilePath End With End Sub

Hallo Oli,
universeller einsetzbar wird der Code, wenn man Erweiterung und Dateiformat mit einbezieht.

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

Sub SpeichernUnter()
  Dim strFilePath As String
  Dim strExt As String, lngFormat As Long
  
  Const cstrStdPath = "h:\bewatec\"
  
  getFileExtAndFormat ThisWorkbook, strExt, lngFormat
  
  With ThisWorkbook
    With .Worksheets("Firma")
      strFilePath = cstrStdPath & IIf(Right(cstrStdPath, 1) = "\", "", "\") & _
        .Range("B1") & IIf(Right(.Range("B1"), 1) = "\", "", "\") & "_Wartung2011" & strExt
    End With
    
    If MakeSureDirectoryPathExists(strFilePath) <> 0 Then .SaveAs strFilePath, lngFormat
  End With
  
End Sub


Private Function getFileExtAndFormat(ByRef WB As Workbook, ByRef strExt As String, ByRef lngFormat As Long)
  With WB
    If Val(Application.Version) < 12 Then
      strExt = ".xls": lngFormat = -4143
    Else
      Select Case WB.FileFormat
        Case 51: strExt = ".xlsx": lngFormat = 51
        Case 52:
          If .HasVBProject Then
            strExt = ".xlsm": lngFormat = 52
          Else
            strExt = ".xlsx": lngFormat = 51
          End If
        Case 56: strExt = ".xls": lngFormat = 56
        Case Else: strExt = ".xlsb": lngFormat = 50
      End Select
    End If
  End With
End Function

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

Speichern mit Unterordner aus Zelle

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Speichern mit Unterordner aus Zelle

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread