エクセルVBAで場所の指定

質問

また質問させていただきます。先日Wendy02さんに以下のコードを
お教えいただきました。
少し内容を変更したくまた質問をさせていただきます。
移動前のフォルダ名をあらかじめフルパスで指定してある
セルがあるのですが、そのセルには
C:\Documents and Settings\user\デスクトップ\Test1Fold
とあるとして、そのパスを取得して
SourceDir = SourceFolder & "Test1Fold\"　'末尾に\ は付けなくてよい

の部分は移動前のフォルダが変わっても対応できるようにしたいのですが、どのようにするのかわかりません。どのように記述すればいいでしょうか？よろしくお願いします。

Sub MoveDirectries()
　　Dim SourceFolder As String
　　Dim SourceDir As String
　　Dim DestFolder As String
　　Dim DestDir As String
　　Dim ArDirs() As String
　　Dim FOLname As String
　　Dim i As Integer
　　Dim v As Variant
　　Dim ret As Integer

　　'Win 2000以上
　　Const MYCMD1 As String = "CMD /C MOVE " '末尾は半角スペースを開ける

　　SourceFolder = ActiveWorkbook.Path & "\" 'ベースのフォルダ（元）\ は必ず付ける
　　DestFolder = ActiveWorkbook.Path & "\" 'ベースのフォルダ（先）\ は必ず付ける

　　SourceDir = SourceFolder & "Test1Fold\"　'末尾に\ は付けなくてよい
　　DestDir = DestFolder & "Test1AFold\"

　　'最終フォルダに　\ があったら省く
　　If Right(SourceDir, 1) = "\" Then SourceDir = Mid$(SourceDir, 1, Len(SourceDir) - 1)
　　If Right(DestDir, 1) = "\" Then DestDir = Mid$(DestDir, 1, Len(DestDir) - 1)

　　ReDim Preserve ArDirs(i)
　　FOLname = Dir(SourceDir & "\", vbDirectory)
　　Do While FOLname <> ""
　　　　If FOLname <> "." And FOLname <> ".." Then
　　　　　　If (GetAttr(SourceDir & "\" & FOLname) And vbDirectory) = vbDirectory Then
　　　　　　　　ReDim Preserve ArDirs(i)
　　　　　　　　ArDirs(i) = FOLname
　　　　　　　　i = i + 1
　　　　　　End If
　　　　End If
　　　　FOLname = Dir
　　Loop
　　'フォルダの下のフォルダを作るのは一回のみ
　　For Each v In ArDirs()
　　　　If Dir(DestDir & "\" & v, vbDirectory) = "" Then
　　　　　ret = Shell(MYCMD1 & """" & SourceDir & "\" & v & """" & " " & """" & DestDir & """")

　　　　ElseIf Dir(DestDir & "\" & v & "\" & v, vbDirectory) = "" Then
　　　　　　ret = Shell(MYCMD1 & """" & SourceDir & "\" & v & """" & " " & """" & DestDir & "\" & v & """")
　　　　End If
　　Next v
End Sub

回答No.1

Wendy02 · ベストアンサー

こんにちは。Wendy02です。

ソース元のフォルダが変わる場合に対して、フォルダ表示ダイアログを付けてみました。
BrowseForFolder(0, "フォルダを選択してください", 0, 0)
この、第４番目の引数、0 を、いつも開く親フォルダを書き込めば、そこから開くことが可能です。

例：
BrowseForFolder(0, "フォルダを選択してください", 0, "C:\")
また、第４番目の引数の定数には、5 -My Document(User) などがあります。

------------------------------------------------------

Sub CopyDirectriesR()
　　Dim SourceFolder As String
　　Dim SourceDir As String
　　Dim DestFolder As String
　　Dim DestDir As String
　　Dim ArDirs() As String
　　Dim FOLname As String
　　Dim i As Integer
　　Dim v As Variant
　　Dim ret As Integer
　　Dim shl_Folder As Object

　　''移動先フォルダここは任意の設定
　　DestFolder = ActiveWorkbook.Path & "\" 'ベースのフォルダ（先）\ は必ず付ける
　　DestDir = DestFolder & "Test1AFold\"

　　'Win 2000以上
　　Const MYCMD1 As String = "CMD /C MOVE " '末尾は半角スペースを開ける
　　''Win 9X系（未検査）
　　''Const MYCMD1 As String = "COMMAND.COM /C MOVE " '末尾は半角スペースを開ける

　　''ソース側のフォルダ表示ダイアログ
　　Set shl_Folder = CreateObject("Shell.Application"). _
　　　　BrowseForFolder(0, "フォルダを選択してください", 0, 0)
　　　　'BrowseForFolder(lngHWND, strTitle, lngOptions, [RootFolder])
　　　　'lngHWND は0, strTitle は適当に, lngOptions =0, ルート =0 は、ユーザーデスクトップ

　　　　If Not shl_Folder Is Nothing Then
　　　　　SourceDir = shl_Folder.Items.Item.Path
　　Else
　　　Exit Sub
　　End If

　　'最終フォルダに　\ があったら省く
　　If Right(DestDir, 1) = "\" Then DestDir = Mid$(DestDir, 1, Len(DestDir) - 1)

　　ReDim Preserve ArDirs(i)

　　FOLname = Dir(SourceDir & "\", vbDirectory)
　　Do While FOLname <> ""
　　　　If FOLname <> "." And FOLname <> ".." Then
　　　　　　If (GetAttr(SourceDir & "\" & FOLname) And vbDirectory) = vbDirectory Then
　　　　　　　　ReDim Preserve ArDirs(i)
　　　　　　　　ArDirs(i) = FOLname
　　　　　　　　i = i + 1
　　　　　　End If
　　　　End If
　　　　FOLname = Dir
　　Loop
　　'フォルダの下のフォルダを作るのは一回のみ
　　For Each v In ArDirs()
　　　　If Dir(DestDir & "\" & v, vbDirectory) = "" Then
　　　　　Debug.Print MYCMD1 & """" & SourceDir & "\" & v & """" & " " & """" & DestDir & """"
　　　　　ret = Shell(MYCMD1 & """" & SourceDir & "\" & v & """" & " " & """" & DestDir & """")

　　　　ElseIf Dir(DestDir & "\" & v & "\" & v, vbDirectory) = "" Then
　　　　　　ret = Shell(MYCMD1 & """" & SourceDir & "\" & v & """" & " " & """" & DestDir & "\" & v & """")
　　　　End If
　　Next v
End Sub

お礼

Wendy02さんありがとうございます。今回もすごいアイデアで
感激しています。指定の仕方覚えました。応用してできるまで
は時間がかかるかもしれませんが、大変勉強になりました。
ありがとうございました。