Saya memiliki menu pull down perusahaan yang diisi oleh daftar di lembar lain. Tiga kolom, Perusahaan, Job #, dan Nomor Bagian.
Ketika sebuah pekerjaan dibuat, saya memerlukan folder untuk perusahaan tersebut dan sub-folder untuk Nomor Bagian tersebut.
Jika Anda menyusuri jalan itu akan terlihat seperti:
C:\Images\Nama Perusahaan\Nomor Bagian\
Jika nama perusahaan atau nomor Part sudah ada, jangan membuat, atau menimpa yang lama. Cukup lanjutkan ke langkah berikutnya. Jadi, jika kedua folder ada, tidak terjadi apa-apa, jika salah satu atau keduanya tidak ada, buatlah sesuai kebutuhan.
Pertanyaan lain, apakah ada cara untuk membuatnya agar berfungsi di Mac dan PC yang sama?
Satu sub dan dua fungsi. Sub membangun path Anda dan menggunakan fungsi untuk memeriksa apakah path tersebut ada dan membuat jika tidak. Jika path lengkap sudah ada, maka akan diteruskan begitu saja. Ini akan bekerja di PC, tetapi Anda harus memeriksa apa yang perlu dimodifikasi untuk bekerja di Mac juga.
'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
Berikut ini'sub pendek tanpa penanganan kesalahan yang membuat subdirektori:
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