oh, ja danke...so geht es...;-) ich denke zwar das es noch ein wenig eleganter geht, da ich for 5 to 10000 eingetragen habe und der code spätestens
dann nicht mehr mitspielt...aber für den moment funktioniert es erstmal...danke dafür...
hier noch einmal wie es jetzt aussieht...
Private Sub alle_Ordner_neu_Click()
Dim lngReturn As Long, lngErrorNumber As Long
Dim strBuffer As String
Dim intNr As Long
Dim c As Integer
With Worksheets("Projektübersicht").Columns(1)
c = .Cells(ActiveCell.Row, 1).End(xlUp).Row
c = c + 1
For c = 5 To 10000
If Worksheets("Projektübersicht").Cells(c, 1) = "" Then Exit For
Application.EnableEvents = False
lngReturn = MakeSureDirectoryPathExists("C:\" & "Projekte" & "\" & Worksheets("Projektübersicht").Cells(c, 33) & "\" & Year(Now) & "\" & Worksheets("Projektübersicht").Cells(c, 3) & "\" & "Intern" & " " & Worksheets("Projektübersicht").Cells(c, 1).Text & " " & Worksheets("Projektübersicht").Cells(c, 3) & "\\" & "Auftragsdokumentation_Blanco" & "\")
MakeSureDirectoryPathExists ("C:\" & "Projekte" & "\" & Worksheets("Projektübersicht").Cells(c, 33) & "\" & Year(Now) & "\" & Worksheets("Projektübersicht").Cells(c, 3) & "\" & "Intern" & " " & Worksheets("Projektübersicht").Cells(c, 1).Text & " " & Worksheets("Projektübersicht").Cells(c, 3) & "\\" & "Auftragsdokumentation_Rücklauf" & "\" & "\" & "Fotodokumentation" & "\")
MakeSureDirectoryPathExists ("C:\" & "Projekte" & "\" & Worksheets("Projektübersicht").Cells(c, 33) & "\" & Year(Now) & "\" & Worksheets("Projektübersicht").Cells(c, 3) & "\" & "Intern" & " " & Worksheets("Projektübersicht").Cells(c, 1).Text & " " & Worksheets("Projektübersicht").Cells(c, 3) & "\\" & "Auftragsdokumentation_Rücklauf" & "\" & "\" & "Durchführungsbestätigungen" & "\")
MakeSureDirectoryPathExists ("C:\" & "Projekte" & "\" & Worksheets("Projektübersicht").Cells(c, 33) & "\" & Year(Now) & "\" & Worksheets("Projektübersicht").Cells(c, 3) & "\" & "Intern" & " " & Worksheets("Projektübersicht").Cells(c, 1).Text & " " & Worksheets("Projektübersicht").Cells(c, 3) & "\\" & "Anfrage, Angebot, Projektdaten" & "\" & "\" & "Kundenfotos" & "\")
MakeSureDirectoryPathExists ("C:\" & "Projekte" & "\" & Worksheets("Projektübersicht").Cells(c, 33) & "\" & Year(Now) & "\" & Worksheets("Projektübersicht").Cells(c, 3) & "\" & "Intern" & " " & Worksheets("Projektübersicht").Cells(c, 1).Text & " " & Worksheets("Projektübersicht").Cells(c, 3) & "\\" & "Anfrage, Angebot, Projektdaten" & "\" & "\" & "Mailverkehr" & "\")
If Dir("C:\" & "Projekte" & "\" & Worksheets("Projektübersicht").Cells(c, 33) & "\" & Year(Now) & "\" & Worksheets("Projektübersicht").Cells(c, 3) & "\" & "Intern" & " " & Worksheets("Projektübersicht").Cells(c, 1).Text & " " & Worksheets("Projektübersicht").Cells(c, 3) & "\" & "Verlauf.txt") = "" Then
Open ("C:\" & "Projekte" & "\" & Worksheets("Projektübersicht").Cells(c, 33) & "\" & Year(Now) & "\" & Worksheets("Projektübersicht").Cells(c, 3) & "\" & "Intern" & " " & Worksheets("Projektübersicht").Cells(c, 1).Text & " " & Worksheets("Projektübersicht").Cells(c, 3) & "\" & "Verlauf.txt") For Output As #1
Print #1, "Projektverlauf:" & " " & "Datei wurde angelegt am:" & " " & Date & "/" & " " & Time & " " & "Für das Projekt:" & "Intern" & " " & Worksheets("Projektübersicht").Cells(c, 1).Text & " "
Close #1
End If
If lngReturn = 0 Then
lngErrorNumber = Err.LastDllError
strBuffer = Space$(200)
Call FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM, ByVal 0&, _
lngErrorNumber, LANG_NEUTRAL, strBuffer, 200, ByVal 0&)
Call msgbox("Fehler: " & CStr(lngErrorNumber) & vbLf & vbLf & _
strBuffer, vbCritical, "Fehler beim Anlegen der Ordner")
Else
Cells(c, 41).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="C:\" & "Projekte" & "\" & Worksheets("Projektübersicht").Cells(c, 33) & "\" & Year(Now) & "\" & Worksheets("Projektübersicht").Cells(c, 3) & "\" & "Intern" & " " & Worksheets("Projektübersicht").Cells(c, 1).Text & " " & Worksheets("Projektübersicht").Cells(c, 3), TextToDisplay:="angelegt am" & " " & Date & " " & "von" & " " & Environ("COMPUTERNAME") 'Hyperlink wird eingefügt
End If
Next c
End With
Call msgbox("Die Ordner wurden erfolgreich angelegt.", vbInformation, "Information")
Application.EnableEvents = True
Unload Me
End Sub
|