Live-Forum - Die aktuellen Beiträge
Datum
Titel
23.04.2024 16:27:34
Excel Starthinweis - Arbeitsmappenleistung überprüfen ...
23.04.2024 16:15:16
Mittels VBA vordefinierte Kommentare in Zellen einfügen?
23.04.2024 14:59:21
Zellformel in VBA
23.04.2024 14:47:39
Formel SVERWEIS
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1132to1136
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1132to1136
1132to1136
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Ordner erstellen

Ordner erstellen
Heinz
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"

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Ordner erstellen
01.02.2010 17:48:49
Tino
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
Anzeige
Pfad erstellen und Datei speichern
01.02.2010 17:49:18
NoNet
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
Anzeige
AW: Ordner erstellen
01.02.2010 17:49:45
Ramses
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
Anzeige
AW: Ordner erstellen
01.02.2010 19:10:06
Heinz
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

Anzeige
ungetestet nur rein kopiert...
01.02.2010 21:53:41
Tino
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

Anzeige
AW: ungetestet nur rein kopiert...
02.02.2010 09:51:26
Heinz
Hallo Tino
Jetzt habe ich den Fehler
strPath = Variable nicht definiert.
Danke & Gruß
Heinz
ist definiert, direkt nach Private Sub oT.
02.02.2010 10:20:12
Tino
AW: ist definiert, direkt nach Private Sub oT.
02.02.2010 10:46:16
Heinz
Hallo Tino
Ich bin soooooooo Blöd !!
Funktioniert wie gewollt.
Recht herzlichen Dank
Gruß
Heinz

Links zu Excel-Dialogen

TextBox

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige