web-dev-qa-db-ja.com

Excel VBAにフォルダーとサブフォルダーを作成する方法はありますか?

わかりました。ExcelVBAのマスターであることがわかっている人のために、別のタブのリストが表示される会社のプルダウンメニューがあります。会社、ジョブ番号、部品番号の3つの列。

私が行っているのは、ジョブを作成するときに、会社を作成するためのフォルダーが必要であり、次に、パーツ番号に基づいてサブフォルダーを作成する必要があるということです。したがって、パスをたどると、次のようになります。

C:\Images\Company Name\Part Number\

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

これは理にかなっていますか?

これがどのように機能し、どのように機能させるかを理解できるように誰かが私を助けることができれば、それは大歓迎です。再度、感謝します。

それが多すぎない場合の別の質問は、MacとPCで同じように動作するようにする方法がありますか?

25
Matt Ridge

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
26
Scott Holtzman

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
34
Martin

同じ、より少ないコード、はるかに効率の良い方法を見つけました。 "" ""は、フォルダー名に空白が含まれる場合にパスを引用することに注意してください。コマンドラインmkdirは、必要に応じてパス全体を存在させるために中間フォルダーを作成します。

If Dir(YourPath, vbDirectory) = "" Then
    Shell ("cmd /c mkdir """ & YourPath & """")
End If
11
Leandro Jacques
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
5
Chandan Kumar

ここにはいくつかの良い答えがありますので、プロセスの改善を追加します。フォルダーが存在するかどうかを判断するより良い方法(すべてのコンピューターが使用を許可されていないFileSystemObjectsを使用しないでください):

Function FolderExists(FolderPath As String) As Boolean
     FolderExists = True
     On Error Resume Next
     ChDir FolderPath
     If Err <> 0 Then FolderExists = False
     On Error GoTo 0
End Function

同様に、

Function FileExists(FileName As String) As Boolean
     If Dir(FileName) <> "" Then FileExists = True Else FileExists = False
EndFunction
3
SandPiper

これは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

2
Brett

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
0
Patrick Honorez

これはすでに回答されており、すでに多くの良い回答がありましたが、ここに来て解決策を探している人のために、最終的に解決したものを投稿することができました。

次のコードは、ドライブ( "C:\ Users ..."など)とサーバーアドレス(スタイル: "\ Server\Path ..")へのパスの両方を処理し、引数としてパスを取り、任意のパスを自動的に削除します。そこからのファイル名(既にディレクトリパスの場合は末尾に「\」を使用)、何らかの理由でフォルダを作成できなかった場合はfalseを返します。そうそう、要求された場合、サブサブサブディレクトリも作成します。

Public Function CreatePathTo(path As String) As Boolean

Dim sect() As String    ' path sections
Dim reserve As Integer  ' number of path sections that should be left untouched
Dim cPath As String     ' temp path
Dim pos As Integer      ' position in path
Dim lastDir As Integer  ' the last valid path length
Dim i As Integer        ' loop var

' unless it all works fine, assume it didn't work:
CreatePathTo = False

' trim any file name and the trailing path separator at the end:
path = Left(path, InStrRev(path, Application.PathSeparator) - 1)

' split the path into directory names
sect = Split(path, "\")

' what kind of path is it?
If (UBound(sect) < 2) Then ' illegal path
    Exit Function
ElseIf (InStr(sect(0), ":") = 2) Then
    reserve = 0 ' only drive name is reserved
ElseIf (sect(0) = vbNullString) And (sect(1) = vbNullString) Then
    reserve = 2 ' server-path - reserve "\\Server\"
Else ' unknown type
    Exit Function
End If

' check backwards from where the path is missing:
lastDir = -1
For pos = UBound(sect) To reserve Step -1

    ' build the path:
    cPath = vbNullString
    For i = 0 To pos
        cPath = cPath & sect(i) & Application.PathSeparator
    Next ' i

    ' check if this path exists:
    If (Dir(cPath, vbDirectory) <> vbNullString) Then
        lastDir = pos
        Exit For
    End If

Next ' pos

' create subdirectories from that point onwards:
On Error GoTo Error01
For pos = lastDir + 1 To UBound(sect)

    ' build the path:
    cPath = vbNullString
    For i = 0 To pos
        cPath = cPath & sect(i) & Application.PathSeparator
    Next ' i

    ' create the directory:
    MkDir cPath

Next ' pos

CreatePathTo = True
Exit Function

Error01:

End Function

誰かがこれが役に立つと思うかもしれません。楽しい! :-)

0
Sascha L.

以下に、サブディレクトリを作成するエラー処理なしの短いサブを示します。

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
0
alexkovelsky