Ich habe ein Pulldown-Menü mit Unternehmen, das durch eine Liste auf einem anderen Blatt gefüllt wird. Drei Spalten: Unternehmen, Auftragsnummer und Teilenummer.
Wenn ein Auftrag erstellt wird, benötige ich einen Ordner für das besagte Unternehmen und einen Unterordner für die besagte Teilenummer.
Wenn Sie den Weg nach unten gehen, würde es wie folgt aussehen:
C:\Images\Firmenname\Teilenummer\
Wenn entweder der Firmenname oder die Teilenummer bereits vorhanden sind, brauchen Sie sie nicht zu erstellen oder die alten zu überschreiben. Fahren Sie einfach mit dem nächsten Schritt fort. Wenn also beide Ordner vorhanden sind, passiert nichts, wenn einer oder beide nicht vorhanden sind, erstellen Sie wie erforderlich.
Eine weitere Frage: Gibt es eine Möglichkeit, das Programm so zu gestalten, dass es auf Macs und PCs in gleicher Weise funktioniert?
Eine Sub und zwei Funktionen. Die Sub erstellt den Pfad und verwendet die Funktionen, um zu prüfen, ob der Pfad existiert, und erstellt ihn, falls nicht. Wenn der vollständige Pfad bereits existiert, wird er einfach übersprungen. Dies wird auf dem PC funktionieren, aber Sie müssen prüfen, was geändert werden muss, damit es auch auf dem Mac funktioniert.
'requires reference to Microsoft Scripting Runtime
Sub MakeFolder()
Dim strComp As String, strPart As String, strPath As String
strComp = Range("A1") ' assumes company name in A1
strPart = CleanName(Range("C1")) ' assumes part in C1
strPath = "C:\Images\"
If Not FolderExists(strPath & strComp) Then
'company doesn't exist, so create full path
FolderCreate strPath & strComp & "\" & strPart
Else
'company does exist, but does part folder
If Not FolderExists(strPath & strComp & "\" & strPart) Then
FolderCreate strPath & strComp & "\" & strPart
End If
End If
End Sub
Function FolderCreate(ByVal path As String) As Boolean
FolderCreate = True
Dim fso As New FileSystemObject
If Functions.FolderExists(path) Then
Exit Function
Else
On Error GoTo DeadInTheWater
fso.CreateFolder path ' could there be any error with this, like if the path is really screwed up?
Exit Function
End If
DeadInTheWater:
MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
FolderCreate = False
Exit Function
End Function
Function FolderExists(ByVal path As String) As Boolean
FolderExists = False
Dim fso As New FileSystemObject
If fso.FolderExists(path) Then FolderExists = True
End Function
Function CleanName(strName as String) as String
'will clean part # name so it can be made into valid folder name
'may need to add more lines to get rid of other characters
CleanName = Replace(strName, "/","")
CleanName = Replace(CleanName, "*","")
etc...
End Function
Private Sub CommandButton1_Click()
Dim fso As Object
Dim tdate As Date
Dim fldrname As String
Dim fldrpath As String
tdate = Now()
Set fso = CreateObject("scripting.filesystemobject")
fldrname = Format(tdate, "dd-mm-yyyy")
fldrpath = "C:\Users\username\Desktop\FSO\" & fldrname
If Not fso.folderexists(fldrpath) Then
fso.createfolder (fldrpath)
End If
End Sub
Hier's kurzes Sub ohne Fehlerbehandlung, das Unterverzeichnisse erstellt:
Public Function CreateSubDirs(ByVal vstrPath As String)
Dim marrPath() As String
Dim mint As Integer
marrPath = Split(vstrPath, "\")
vstrPath = marrPath(0) & "\"
For mint = 1 To UBound(marrPath) 'walk down directory tree until not exists
If (Dir(vstrPath, vbDirectory) = "") Then Exit For
vstrPath = vstrPath & marrPath(mint) & "\"
Next mint
MkDir vstrPath
For mint = mint To UBound(marrPath) 'create directories
vstrPath = vstrPath & marrPath(mint) & "\"
MkDir vstrPath
Next mint
End Function