会社のプルダウンメニューがあり、それが別のシートのリストに入力されています。会社名、ジョブ番号、部品番号の3つの列があります。
ジョブが作成されると、会社のためのフォルダと部品番号のためのサブフォルダが必要です。
パスをたどると以下のようになります。
C:Images%Company Name%Part Number%!
もし、会社名や品番のどちらかが存在していれば、作成したり、古いものを上書きしたりしないでください。ただ次のステップに進みます。つまり、両方のフォルダが存在する場合は何も起こらず、片方または両方が存在しない場合は必要に応じて作成します。
もう一つの質問ですが、MacとPCで同じように動作するようにする方法はありますか?
1つのサブと2つのファンクション。サブはパスを構築し、関数はパスが存在するかどうかをチェックし、存在しない場合は作成します。もしフルパスがすでに存在していれば、そのまま通過してしまいます。 これはPCでも動作しますが、Macで動作させるためには何を修正する必要があるかを確認する必要があります。
'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
ここでは、サブディレクトリを作成するエラー処理のない短いサブを紹介します。
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