Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema TextBox
BildScreenshot zu TextBox TextBox-Seite mit Beispielarbeitsmappe aufrufen

Ordner erstellen | Herbers Excel-Forum


Betrifft: Ordner erstellen von: Heinz H
Geschrieben am: 01.02.2010 17:20:14

Hallo Leute

Habe unten ein Makro in einer UF, der mir ein Neues Woorkbook erstellt.
Das funkt. auch alles.

Nur sollte er mir zuerst einen Ordner mit "Stundenaufzeichnung" & Range("B3") erstellen.wo dieses Workbook gespeichert wird.
Speicherort ist immer dort wo das Workbook is.t zB. C:/Desktop/

Könnte mir bitte jemand helfen ?
Gruß
Heinz

  ActiveWorkbook.SaveAs ThisWorkbook.Path & "/" & "Stundenaufzeichnung  " & Range("B3") & " - "  _
& _
        Format(Range("G1"), "mmmm") & " " & Year(Range("G1")) & ".xls"

  

Betrifft: AW: Ordner erstellen von: Tino
Geschrieben am: 01.02.2010 17:48:49

Hallo,
versuch es mal mit diesem Code.

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

Sub Beipiel()
Dim strPath As String
Dim lngPath As Long

If Range("B3") <> "" And IsDate(Range("G1")) Then
    
    strPath = IIf(Left$(Range("B3"), 1) = "\", Range("B3"), "\" & Range("B3"))
    strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
    
    strPath = _
        IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\") & _
        "Stundenaufzeichnung" & strPath
    
    lngPath = apiCreateFullPath(strPath)
    
    If lngPath = 1 Then
     ThisWorkbook.SaveAs strPath & Format(Range("G1"), "mmmm") & " " & Year(Range("G1")) & ".xls"
    Else
     MsgBox "Ordner konnte nicht angelegt oder gefunden werden!", vbCritical
    End If

End If
End Sub
Gruß Tino


  

Betrifft: Pfad erstellen und Datei speichern von: NoNet
Geschrieben am: 01.02.2010 17:49:18

Hallo Heinz,

das funktioniert grundsätzlich so :

'API-Deklaration :
Private Declare Function MakePath Lib "imagehlp.dll" _
    Alias "MakeSureDirectoryPathExists" (ByVal lpPath As String) As Long

Sub DateiSpeichern()
    Dim lngResult As Long
    Dim strOrdner As String
    
    ' Pfadname mit "\" am Ende !!
    strOrdner = ThisWorkbook.Path & "\" & "Stundenaufzeichnung  " & Range("B3")]  & "\" 
    lngResult = MakePath(strOrdner)
    
    ActiveWorkbook.SaveAs strOrdner & Format(Range("G1"), "mmmm") & " " & Year(Range("G1")) & ". _
xls"
End Sub
Allerdings hab ich nicht so ganz kapiert, welcher Teil den Dateinamen darstellt, daher habe ich jetzt mal vermutet : Format(Range("G1"), "mmmm") & " " & Year(Range("G1")) & ".xls"

Gruß, NoNet


  

Betrifft: AW: Ordner erstellen von: Ramses
Geschrieben am: 01.02.2010 17:49:45

Hallo

probiers mal so

Option Explicit

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

Sub test()
    Dim tmpTar As String
    tmpTar = ThisWorkbook.Path & "\Stundenaufzeichnung" & Range("B3")
    'Verzeichnis erstellen
    MakeSureDirectoryPathExists tmpTar
    'speichern
    ActiveWorkbook.SaveAs tmpTar & "\" & "Stundenaufzeichnung " & Range("B3") & " - " & Format(Range("G1"), "mmmm") & " " & Year(Range("G1")) & ".xls"
End Sub


Gruss Rainer


  

Betrifft: AW: Ordner erstellen von: Heinz H
Geschrieben am: 01.02.2010 19:10:06

Hallo Rainer, NoNet & Tino

Leider kann ich keine neue Sub erzeugen.

Habe jetzt mal den ganzen Code hochgeladen.

Gruß
Heinz

Private Sub cmdUebertragen_Click()

ActiveSheet.Unprotect Password:="Test"

If Me.txtA = "" Then
  MsgBox "Bitte einen Namen eingeben!"
  Exit Sub
ElseIf Me.txtB = "" Then
  MsgBox "Bitte Personalnummer eingeben!"
  Exit Sub
ElseIf Me.txtEintritt = "" Then
  MsgBox "Bitte Eintrittsdatum eingeben."
  Exit Sub
ElseIf Me.txtBeginnStundenliste = "" Then
  MsgBox "Bitte Beginn der Stundenliste eingeben."
  Exit Sub
End If

If Not (txtEintritt Like "??.??.????" And IsNumeric(txtEintritt)) Then
  txtEintritt.SetFocus
  MsgBox "Eingabe in Eintrittsdatum ist Falsch geben sie TT.MM.JJJJ ein"
  Exit Sub
 End If


If Not (txtBeginnStundenliste Like "??.??.????" And IsNumeric(txtBeginnStundenliste)) Then
  txtBeginnStundenliste.SetFocus
  MsgBox "Eingabe in Beginn der Stundenliste ist Falsch geben sie TT.MM.JJJJ ein"
  Exit Sub
 End If

[B3].Value = txtA.Value 'Name
[A3].Value = txtB.Value 'PersNummer
[F1].Value = txtBeginnStundenliste.Value 'Beginn Stundenliste



[B101].Value = txtEintritt.Value 'Eintrittsdatum
[B102].Value = TextBox27.Value 'Urlaubsanspruch im Jahr
[B103].Value = TextBox28.Value 'Bildungsurlaub im Jahr
[B104].Value = TextBox29.Value 'Pflegefreistellung im Jahr


Call WochenendeWeg(True)

  ActiveWorkbook.SaveAs ThisWorkbook.Path & "/" & "Stundenaufzeichnung  " & Range("B3") & " - "  _
& _
        Format(Range("G1"), "mmmm") & " " & Year(Range("G1")) & ".xls"
                    
  
ActiveSheet.Unprotect Password:="Test"
        
  ActiveSheet.Shapes(Application.Caller).Delete 'Löscht den Button Neues Personalblatt  _
erstellen
  ActiveSheet.Shapes("Button 7").Visible = False 'Löscht den Button Blattschutz aus
  ActiveSheet.Shapes("Button 8").Visible = False 'Löscht den Button Blattschutz ein
  'VBComponents.Remove .VBComponents("Modul") = False 'Löscht das Modul 1
  




ActiveSheet.Protect Password:="Test"

Unload Me

End Sub



  

Betrifft: ungetestet nur rein kopiert... von: Tino
Geschrieben am: 01.02.2010 21:53:41

Hallo,

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

Private Sub cmdUebertragen_Click()
Dim strPath As String
Dim lngPath As Long

ActiveSheet.Unprotect Password:="Test"

If Me.txtA = "" Then
  MsgBox "Bitte einen Namen eingeben!"
  Exit Sub
ElseIf Me.txtB = "" Then
  MsgBox "Bitte Personalnummer eingeben!"
  Exit Sub
ElseIf Me.txtEintritt = "" Then
  MsgBox "Bitte Eintrittsdatum eingeben."
  Exit Sub
ElseIf Me.txtBeginnStundenliste = "" Then
  MsgBox "Bitte Beginn der Stundenliste eingeben."
  Exit Sub
End If

If Not (txtEintritt Like "??.??.????" And IsNumeric(txtEintritt)) Then
  txtEintritt.SetFocus
  MsgBox "Eingabe in Eintrittsdatum ist Falsch geben sie TT.MM.JJJJ ein"
  Exit Sub
 End If


If Not (txtBeginnStundenliste Like "??.??.????" And IsNumeric(txtBeginnStundenliste)) Then
  txtBeginnStundenliste.SetFocus
  MsgBox "Eingabe in Beginn der Stundenliste ist Falsch geben sie TT.MM.JJJJ ein"
  Exit Sub
 End If

[B3].Value = txtA.Value 'Name
[A3].Value = txtB.Value 'PersNummer
[F1].Value = txtBeginnStundenliste.Value 'Beginn Stundenliste



[B101].Value = txtEintritt.Value 'Eintrittsdatum
[B102].Value = TextBox27.Value 'Urlaubsanspruch im Jahr
[B103].Value = TextBox28.Value 'Bildungsurlaub im Jahr
[B104].Value = TextBox29.Value 'Pflegefreistellung im Jahr


Call WochenendeWeg(True)

If Range("B3") <> "" And IsDate(Range("G1")) Then
    
    strPath = IIf(Left$(Range("B3"), 1) = "\", Range("B3"), "\" & Range("B3"))
    strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
    
    strPath = _
        IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\") & _
        "Stundenaufzeichnung" & strPath
    
    lngPath = apiCreateFullPath(strPath)
    
    If lngPath = 1 Then
     ThisWorkbook.SaveAs strPath & _
     Format(Range("G1"), "mmmm") & " " & Year(Range("G1")) & ".xls"
    Else
     MsgBox "Ordner konnte nicht angelegt oder gefunden werden!", vbCritical
    End If

End If

                    
  
ActiveSheet.Unprotect Password:="Test"
        
  ActiveSheet.Shapes(Application.Caller).Delete 'Löscht den Button Neues Personalblatt _
erstellen
  ActiveSheet.Shapes("Button 7").Visible = False 'Löscht den Button Blattschutz aus
  ActiveSheet.Shapes("Button 8").Visible = False 'Löscht den Button Blattschutz ein
  'VBComponents.Remove .VBComponents("Modul") = False 'Löscht das Modul 1
  




ActiveSheet.Protect Password:="Test"

Unload Me

End Sub



  

Betrifft: AW: ungetestet nur rein kopiert... von: Heinz H
Geschrieben am: 02.02.2010 09:51:26

Hallo Tino

Jetzt habe ich den Fehler

strPath = Variable nicht definiert.

Danke & Gruß
Heinz


  

Betrifft: ist definiert, direkt nach Private Sub oT. von: Tino
Geschrieben am: 02.02.2010 10:20:12




  

Betrifft: AW: ist definiert, direkt nach Private Sub oT. von: Heinz H
Geschrieben am: 02.02.2010 10:46:16

Hallo Tino

Ich bin soooooooo Blöd !!

Funktioniert wie gewollt.

Recht herzlichen Dank

Gruß
Heinz


Beiträge aus den Excel-Beispielen zum Thema "Ordner erstellen"