39

別のシートのリストによって入力される会社のプルダウン メニューがあります。Company、Job #、および Part Number の 3 つの列。

ジョブが作成されると、その会社のフォルダーと、その部品番号のサブフォルダーが必要になります。

パスを下ると、次のようになります。

C:\Images\会社名\部品番号\

会社名または部品番号のいずれかが存在する場合は、作成しないか、古いものを上書きしてください。次のステップに進むだけです。したがって、両方のフォルダーが存在する場合は何も起こりません。一方または両方が存在しない場合は、必要に応じて作成します。

もう 1 つの質問は、Mac と PC で同じように動作するようにする方法はありますか?

4

13 に答える 13

52

PC で動作する別のシンプルなバージョン:

Sub CreateDir(strPath As String)
    Dim elm As Variant
    Dim strCheckPath As String

    strCheckPath = ""
    For Each elm In Split(strPath, "\")
        strCheckPath = strCheckPath & elm & "\"
        If Len(Dir(strCheckPath, vbDirectory)) = 0 Then MkDir strCheckPath
    Next
End Sub
于 2015-11-12T12:23:24.230 に答える
36

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
于 2012-05-29T18:43:45.163 に答える
6 
Private Sub CommandButton1_Click()
    Dim fso As Object
    Dim fldrname As String
    Dim fldrpath As String

    Set fso = CreateObject("scripting.filesystemobject")
    fldrname = Format(Now(), "dd-mm-yyyy")
    fldrpath = "C:\Temp\" & fldrname
    If Not fso.FolderExists(fldrpath) Then
        fso.createfolder (fldrpath)
    End If
End Sub
于 2014-03-13T18:50:09.863 に答える
1

これは AutoCad VBA の魅力のように機能し、Excel フォーラムから入手しました。なんでみんなそんなに複雑にするのかわからない？

よくある質問

質問: 特定のディレクトリが既に存在するかどうかわかりません。存在しない場合は、VBA コードを使用して作成したいと考えています。これどうやってするの？

回答: 次の VBA コードを使用して、ディレクトリが存在するかどうかをテストできます。

(プログラミング コードの混乱を避けるため、以下の引用は省略されています)

If Len(Dir("c:\TOTN\Excel\Examples", vbDirectory)) = 0 Then

   MkDir "c:\TOTN\Excel\Examples"

End If

http://www.techonthenet.com/excel/formulas/mkdir.php

于 2015-01-15T04:13:05.080 に答える
0

サブディレクトリを作成するエラー処理なしの短いサブは次のとおりです。

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
于 2014-03-19T14:17:38.170 に答える
0

Windows以外のシステムで試したことはありませんが、これは私のライブラリにある非常に使いやすいシステムです。特別なライブラリ参照は必要ありません。

Function CreateFolder(ByVal sPath As String) As Boolean
'by Patrick Honorez - www.idevlop.com
'create full sPath at once, if required
'returns False if folder does not exist and could NOT be created, True otherwise
'sample usage: If CreateFolder("C:\toto\test\test") Then debug.print "OK"
'updated 20130422 to handle UNC paths correctly ("\\MyServer\MyShare\MyFolder")

    Dim fs As Object 
    Dim FolderArray
    Dim Folder As String, i As Integer, sShare As String

    If Right(sPath, 1) = "\" Then sPath = Left(sPath, Len(sPath) - 1)
    Set fs = CreateObject("Scripting.FileSystemObject")
    'UNC path ? change 3 "\" into 3 "@"
    If sPath Like "\\*\*" Then
        sPath = Replace(sPath, "\", "@", 1, 3)
    End If
    'now split
    FolderArray = Split(sPath, "\")
    'then set back the @ into \ in item 0 of array
    FolderArray(0) = Replace(FolderArray(0), "@", "\", 1, 3)
    On Error GoTo hell
    'start from root to end, creating what needs to be
    For i = 0 To UBound(FolderArray) Step 1
        Folder = Folder & FolderArray(i) & "\"
        If Not fs.FolderExists(Folder) Then
            fs.CreateFolder (Folder)
        End If
    Next
    CreateFolder = True
hell:
End Function
于 2014-11-14T16:56:08.657 に答える