みんなの「教えて(疑問・質問)」にみんなで「答える」Q&Aコミュニティ

こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

VBAで新しいフォルダを作成するには

エクセル2010です。
新しいフォルダを作成するにはMkDir関数というのはわかりますが、フォルダがなければ作る、あれば作らないようにしたいのです。
そのやりかたをお教えいただけませんでしょうか?

やりたいことは以下のようなことです。
まず、対象フォルダを指定します。
その中に多数のエクセルのBOOKがあります。
このマクロがあるBOOKのSheet1のA列に「名前リスト」があります。
名前が一致するものを、ファイルコピーして、「名前リスト」の右隣B列のセルにある「区分リスト」と同じ名前のサブフォルダ(このマクロがあるBOOKのフォルダのすぐ下です。)に貼り付ける。

ここまでは、以下のコードで少量のデータでのテストはうまくいきました。
しかし、実際には対象が1,000件近くあり、事前に作っておかなければいけないサブフォルダも何十かになります。
そこで、あらかじめサブフォルダを用意するのではなく、このマクロを作動させると自動的にサブフォルダまで作るようにできないかと欲張った質問です。

Sub TEST01()
  Dim myPth(1) As String
  Dim myCl As Range
  Dim wb As Workbook
  
  Set wb = ThisWorkbook
  myPth(0) = wb.Path
  
  With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then
      myPth(1) = .SelectedItems(1) '対象フォルダ指定
    Else
      MsgBox "キャンセル"
      Exit Sub
    End If
  End With
  
  With wb.Sheets("Sheet1")
    For Each myCl In .Range("A2:A11")
      FileCopy myPth(1) & "\" & CStr(myCl.Value) & ".xlsx", myPth(0) & "\" & myCl.Offset(, 1).Value & "\" & CStr(myCl.Value) & ".xlsx"
      myCl.Offset(, 2).Value = "完了"
    Next myCl
  End With

End Sub

投稿日時 - 2013-06-25 17:24:34

QNo.8149395

困ってます

質問者が選んだベストアンサー

Dir()関数でディレクトリが存在するかどうかを確認できます。

以下は例です。

SaveDir = myPth(0) & "\" & myCl.Offset(, 1).Value
If Dir(SaveDir, vbDirectory) = "" Then
MkDir SaveDir
End If

こういったものをFileCopyの前に挿入すればどうでしょうか?

投稿日時 - 2013-06-25 17:44:34

お礼

MSZ006さん、さっそくありがとうございます。
Dir関数でファイル名が取得できることは知ってましたがフォルダ名もできるんですね!
以下のようにやってみました。
おかげさまでサンプルでのテストはうまくいきました。
助かりました。ありがとうございます。

Sub Sample02()
  Dim myPth(1) As String, SaveDir As String, Fname As String
  Dim myCl As Range
  Dim wb As Workbook
  Set wb = ThisWorkbook
  myPth(0) = wb.Path
  
  With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then
      myPth(1) = .SelectedItems(1) '対象フォルダ指定
    Else
      MsgBox "キャンセル"
      Exit Sub
    End If
  End With
  
  With wb.Sheets("打診先")
    For Each myCl In .Range("A2:A9") '対象リスト
      SaveDir = myPth(0) & "\" & myCl.Offset(, 1).Value 'サブフォルダ
      If Dir(SaveDir, vbDirectory) = "" Then
        MkDir SaveDir '無ければ作成
      End If
      Fname = Dir(myPth(1) & "\" & CStr(myCl.Value) & ".xlsx")
      If Fname <> "" Then '念のため確認
        FileCopy myPth(1) & "\" & Fname, SaveDir & "\" & Fname
        myCl.Offset(, 2).Value = "完了"
      Else
        myCl.Offset(, 2).Value = "該当なし"
      End If
    Next myCl
  End With

End Sub

投稿日時 - 2013-06-26 15:10:55

ANo.1

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(1)

あなたにオススメの質問