einen wunderschönen guten morgen zusammen....
ich habe mal wieder ein kleines problem und benötige daher eure hilfe......
folgender code erstellt für meine projekte ordnerstrukturen, funktioniert sehr gut.
Nur hätte ich gern, das der code selbstständig bei der ersten leeren zelle in spalte a aufhört zu arbeiten, momentan begrenze ich die
for next schleife noch einfach mit einer zahl. Ich denke dass das mit einer do loop schleife einfach funktionieren wird, wiß aber nicht wie ich das
umschreiben muss, damit es passt...
hier der code...
Private Sub alle_Ordner_neu_Click()
Dim lngReturn As Long, lngErrorNumber As Long
Dim strBuffer As String
Dim intNr As Long
Dim c As Variant
Dim counter As Integer
With Worksheets("Projektübersicht").Columns(1)
c = .Cells(ActiveCell.Row, 1).End(xlUp).Row
c = c + 4
For c = 4 To 115 'Cells(Rows.Count, 1).End(xlUp).Row
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 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
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
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")
Unload Me
End Sub
|