VBAで新しいフォルダを作成するには
- 新しいフォルダを作成する方法について、VBAを使用してエクセル2010でフォルダを作成する方法を学びたいです。
- MkDir関数を使用してフォルダを作成する方法はわかりますが、既にフォルダが存在する場合には作成しないようにしたいです。
- また、エクセルのBOOK内の特定のシートにあるデータを使ってフォルダ作成を行い、ファイルのコピーを行いたいと考えています。
- ベストアンサー
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
- emaxemax
- お礼率100% (828/828)
- その他MS Office製品
- 回答数1
- ありがとう数1
- みんなの回答 (1)
- 専門家の回答
質問者が選んだベストアンサー
Dir()関数でディレクトリが存在するかどうかを確認できます。 以下は例です。 SaveDir = myPth(0) & "\" & myCl.Offset(, 1).Value If Dir(SaveDir, vbDirectory) = "" Then MkDir SaveDir End If こういったものをFileCopyの前に挿入すればどうでしょうか?
関連するQ&A
- エクセルVBAでBOOKに読み取りパスワード設定
エクセル2013です。 以下のコードで指定した任意のフォルダ内のエクセルに読み取りパスワードを設定できました。 しかし、そのフォルダの下にサブフォルダーがあった場合にサブフォルダ内のBOOKは対象になりません。どのように直せばサブフォルダも対象にできるようになるでしょうか?教えてください。 Sub TEST01() Dim myfdr As String, fname As String Dim mb As Workbook, wb As Workbook Dim n As Long With Application.FileDialog(msoFileDialogFolderPicker) '対象とするフォルダの指定 If .Show = True Then myfdr = .SelectedItems(1) Else MsgBox "キャンセルします。" Exit Sub End If End With Set mb = ThisWorkbook 'このコピー先ブックをmbとする。 fname = Dir(myfdr & "\*.xls*") 'フォルダ内のExcelブックを検索 n = 2 Do Until fname = Empty '全て検索 Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。 With mb.Sheets("Sheet1") '転記 .Cells(n, "B").Value = wb.FullName .Cells(n, "C").Value = wb.Sheets(1).Range("B1").Value End With n = n + 1 'カウント Application.DisplayAlerts = False wb.SaveAs Filename:=wb.FullName, Password:="emaxemax" wb.Close Application.DisplayAlerts = True fname = Dir 'フォルダ内の次のExcelブックを検索 Loop '繰り返す MsgBox n - 2 & "件処理しましました。" End Sub
- ベストアンサー
- Excel(エクセル)
- エクセルVBAでファイル作成
エクセルVBAで、データをフィルタで抽出し、別なBOOKの指定シートに転記し、名前をつけて保存したいのです。一応、下記のコードでテストは成功しました。 しかし下記コードでは1回ごとにデータの転記先を開かなくてはなりません。 処理する件数が多いので、できればいちいち新たに開き直さなくともよい方法はないでしょうか? 最初から開いておいて、転記後名前をつけて保存すると、開いていたファイルが閉じてしまい、うまくいきません。 別BOOKでなく別シートに転記して、そのシートをMoveして別ファイル保存ならわかるのですが、今回はどうしても別BOOKに転記しなければなりません。 よろしくお願いします。 Option Explicit Sub データ分割転記() Dim myPth As String, fname As String Dim myRng As Range, myC As Range Dim i As Long, x As Long Dim wb(2) As Workbook Dim ws As Worksheet Dim t As Single t = Timer Set wb(0) = ThisWorkbook myPth = wb(0).Path With wb(0).Sheets("Key") Set myRng = .Range("A2", .Range("A2").End(xlDown)) 'KeyData End With For Each myC In myRng Application.EnableEvents = False Set wb(1) = Workbooks.Open(Filename:=myPth & "\20150806TEST.xlsm") Set ws = wb(1).Sheets("List") With wb(0).Sheets("DATA") .Range("A1:J1").AutoFilter Field:=4, Criteria1:=myC.Value .Range("A2", .Range("A2").SpecialCells(xlLastCell)).SpecialCells(xlCellTypeVisible).Copy ws.Range("A9") .ShowAllData End With With ws x = .Cells(Rows.Count, "A").End(xlUp).Row myC.Offset(, 2).Value = x '行数確認 .Range("A9").Value = 1 If x > 9 Then .Range("A9").AutoFill Destination:=.Range("A9:A" & x), Type:=xlFillSeries '連番 End If End With wb(1).SaveAs Filename:=myPth & "\作成ファイル\" & myC.Value & ".xlsm" wb(1).Close (False) Application.EnableEvents = True i = i + 1 Next MsgBox i & "件を完了" _ & vbCrLf & Timer - t & " Sec." End Sub *Application.EnableEvents = False を使っているのば別BOOKが持つイベントマクロを作動させないためです。
- ベストアンサー
- Excel(エクセル)
- エクセルVBA フォルダ内のどんなシート名であっても読み込みたい
フォルダ内の別ブック(D3で指定)の「情報」シートを読み込んで対象年月日に該当するデータを抽出して別ブックに貼り付けるものなんですが、下のコードではSet ws = wb.Worksheets("情報")と、なっていて、限定しているのですが、これをD3のファイルのどんなシート名であっても読み込みたいのですが、どのようにコードにしたらいいでしょうか?D3で指定するブックには必ずひとつのシートしかありません。 よろしくお願いします。 Sub test_1() Dim wb As Workbook Dim ws As Worksheet Dim ms As Worksheet Dim nb As Workbook Dim r As Long Set ms = ThisWorkbook.Worksheets("メニュー") Set wb = Workbooks.Open(ms.Parent.Path & "\" & ms.Range("D3").Value) Set ws = wb.Worksheets("情報") Set nb = Workbooks.Add With ws .Range("Q1").AutoFilter _ Field:=17, _ Criteria1:=">=" & ms.Range("D5").Text, _ Operator:=xlAnd, _ Criteria2:="<=" & ms.Range("F5").Text With .AutoFilter.Range r = .Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count If r = 1 Then MsgBox "抽出対象データ無し。" wb.Close False nb.Close False Set wb = Nothing: Set ws = Nothing Set ms = Nothing: Set nb = Nothing Exit Sub End If .Copy End With End With With nb.Worksheets(1) .Paste With .Range("A1:AG1") .Interior.ColorIndex = 6 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With End sub
- ベストアンサー
- オフィス系ソフト
- vba, 複数ブックの同一セルに同一写真を挿入
エクセルVBAの初心者です。使っているのはExcel2007です。 同じフォルダの中にある連番の複数のエクセルファイルに同じ操作を繰り返すマクロを作っています。まず、複数ブックの同一セルに同じ内容の文字列を挿入することはどこかで見つけました。 Sub 複数Book同一セルに同一文字列入力() Dim fName As Variant Dim i As Long Dim WB As Workbook fName = Application.GetOpenFilename(FileFilter:="Microsoft Excelブック,*.xlsx", MultiSelect:=True) If IsArray(fName) Then For i = LBound(fName) To UBound(fName) Set WB = Workbooks.Open(fName(i)) WB.Worksheets(1).Range("A1").Value = "テスト" WB.Close SaveChanges:=True Next End If End Sub また、選択したセルに同じフォルダの中にある写真を挿入するマクロもどこかで拝見しました。 Sub AddPictureSampLinkPaste() Dim myFileName As String Dim myShape As Shape myFileName = ActiveWorkbook.Path & "\Koala.jpg" '--(1) 選択位置に画像ファイルを挿入し、変数myShapeに格納 Set myShape = ActiveSheet.Shapes.AddPicture( _ Filename:=myFileName, _ LinkToFile:=True, _ SaveWithDocument:=False, _ Left:=Selection.Left, _ Top:=Selection.Top, _ Width:=0, _ Height:=0) '--(2) 挿入した画像に対して元画像と同じ高さ・幅にする With myShape .ScaleHeight 1, msoTrue '数字は写真の高さの倍数 .ScaleWidth 1, msoTrue '数字は写真の幅の倍数 End With End Sub ここまではテストで問題なかったので、この二つのマクロを一つにまとめて、同じフォルダにある連番のエクセルブックの同一セルに同一写真を挿入するマクロを作ろうと下記のようにアレンジしましたが、なぜか写真はマクロを記入したブックのアクティブセルに連番のブックの数だけの写真が重なるように貼り付けられるだけで、標的のブックには写真が挿入できません。 Sub 複数Bookの同じ位置に同一写真挿入() Dim fName As Variant Dim i As Long Dim WB As Workbook Dim myFileName As String Dim myShape As Shape fName = Application.GetOpenFilename(FileFilter:="Microsoft Excelブック,*.xlsx", MultiSelect:=True) myFileName = ActiveWorkbook.Path & "\Koala.jpg" If IsArray(fName) Then For i = LBound(fName) To UBound(fName) Set WB = Workbooks.Open(fName(i)) Worksheets("Sheet1").Activate '--(1) 選択位置に画像ファイルを挿入し、変数myShapeに格納 Set myShape = ActiveSheet.Shapes.AddPicture( _ Filename:=myFileName, _ LinkToFile:=True, _ SaveWithDocument:=False, _ Left:=Selection.Left, _ Top:=Selection.Top, _ Width:=0, _ Height:=0) '--(2) 挿入した画像に対して元画像と同じ高さ・幅にする With myShape .ScaleHeight 1, msoTrue .ScaleWidth 1, msoTrue End With WB.Close SaveChanges:=True Next End If End Sub 本当にどこが間違っているか分からず、ここで質問いたします。初心者で分からないところばかりなので、どなたかやさしく教えていただけませんか?よろしくお願いいたします。
- 締切済み
- Excel(エクセル)
- エクセルVBAで読み取りパスワード回避
エクセル2010です。 以下のコードで任意のフォルダ内のエクセルBOOKから所定のデータを取得できます。 しかし、指定フォルダ内に読み取りパスワードが設定されたものがあると、開くことができずに止まってしまいます。 読み取りパスワードが同一で、事前に分かっていればコードにPassword:="AAAABBBB" などと書き入れればいいと思うのですが、事前にはわかりませんし、パスワードもそれぞれ異なります。 そこで、開けなかった場合には、そのBOOKを飛ばしてすすみ、別シートに飛ばしたBOOK名を記録しておきたいのです。 (BOOK作成者にあとからパスワードを聞くため) しかし、残念ながらどのように書けばいいのか思いつきません。 ご指導いただければ幸いです。 Sub TEST001() Dim wb(1) As Workbook Dim ws(1) As Worksheet Dim myFdr As String, fn As String Dim i As Long With Application.FileDialog(msoFileDialogFolderPicker) 'フォルダ指定 If .Show = True Then myFdr = .SelectedItems(1) Else Exit Sub End If End With Application.ScreenUpdating = False '画面更新を一時停止 Set wb(0) = ThisWorkbook 'このコピー先ブックをwb(0)とする。 Set ws(0) = wb(0).Sheets(1) 'wb(0)の1枚目のシートをws(0)とする。 fn = Dir(myFdr & "\*.xls*") 'フォルダ内のExcelブックを検索 Do Until fn = Empty '全て検索 Application.EnableEvents = False Set wb(1) = Workbooks.Open(myFdr & "\" & fn, UpdateLinks:=False, ReadOnly:=True) 'そのブックを開きwb(1)とする。 Set ws(1) = wb(1).Worksheets(1) i = i + 1 ws(0).Cells(i, "A").Value = ws(1).Range("B2") 'ws(0)に転記 ws(0).Cells(i, "B").Value = wb(1).Name ws(0).Cells(i, "C").Value = ws(1).Name wb(1).Close (False) '保存せず閉じる Application.EnableEvents = True fn = Dir 'フォルダ内の次のExcelブックを検索 Loop '繰り返す Application.ScreenUpdating = True '画面更新停止を解除 MsgBox i & "個取得" End Sub
- ベストアンサー
- Excel(エクセル)
- マクロ エクセル2003
いつも回答して頂き感謝しています。 原紙のブックを開き、別の名前を付けて保存するマクロを考えています。 原紙のブックを開くマクロはネットから探して、少し修正して出来あがったのですが、 この開いた原紙のブックに別の名前を付けて保存するマクロで困っています。 ただ単に名前を付けるだけだったら問題無いのですが、 その名前が既に保存されていないか確認した後、保存としたいのです。 ブックを開く記述を少し引用して出来ないかやってみたのですが、 Const Target2 As String = "C:\Users\Owner\Documents\" & NewFile で、定数式が必要です。と表示されエラーが発生してしまいます。 どのように変更したら上手くいくのでしょうか?宜しくお願い致します。 Sub Sample() Dim buf1 As String Dim buf2 As String Dim NewFile As String Dim ws1 As Worksheet Dim wb As Workbook Set ws1 = ThisWorkbook.Worksheets("作成") NewFile = "借入貸出" & ws1.Range("C4").Value & "." & ws1.Range("D4").Value Const Target1 As String = "C:\Users\Owner\Documents\借入貸出原紙.xlsx" Const Target2 As String = "C:\Users\Owner\Documents\" & NewFile & ".xlsx" buf1 = Dir(Target1) If buf1 = "" Then MsgBox Target1 & vbCrLf & "は存在しません", vbExclamation Exit Sub End If For Each wb In Workbooks If wb.Name = buf1 Then Application.DisplayAlerts = False Workbooks("借入貸出原紙.xlsx").Close Application.DisplayAlerts = True End If Next wb Workbooks.Open Target1 buf2 = Dir(Target2) If buf2 = "" Then End If End Sub
- 締切済み
- Excel(エクセル)
- フォルダ作成と別名保存【VBA】
教えてください 現在、下の2つのマクロを使っています。 「O27」の値でフォルダを作るものとブックを別名保存するものです。 これを1つにまとめたいのですが単純に1つにまとめるとフォルダは作成されるのですがブックの別名保存がセルの値を参照してくれません。 また、MkDir でフォルダを作成すると同じ名前のフォルダが先にあるとエラーになってしまいます。 この2点を解消できる方法はないでしょうか? よろしくお願いいたします。 Sub 別名フォルダ() MkDir Worksheets("オーダーシート").Range("O27").Value End Sub Sub 別名保存() Application.Dialogs(xlDialogSaveAs).Show Arg1:=Range("O27").Value End Sub
- ベストアンサー
- その他MS Office製品
- VBA フォルダ内ファイルにマクロ一括処理
フォルダ内ファイルのマクロを一括実行したいです。 フォルダ内ファイル全てに下記のマクロを登録 Sub 値貼り付け() 'シート4番目を選択 Sheets(4).Select 'シート名1文字目が「★」以外のシートを選択 For Each i In ThisWorkbook.Sheets If Not i.Name Like "★*" Then i.Select Replace:=False End If Next i '全セル選択 Cells.Select 'コピー Selection.Copy '値貼り付け Selection.PasteSpecial Paste:=xlPasteValues Cells(1, 1).Select Sheets(1).Select '「.xlsx」で保存 Application.DisplayAlerts = False Dim fso, f Set fso = CreateObject("Scripting.FileSystemObject") With ActiveWorkbook f = fso.GetBaseName(.Name) .SaveAs .Path & "\" & f & "保存.xlsx", FileFormat:=xlWorkbookDefault .Close End With Set fso = Nothing End Sub 一括でマクロを実行する用のファイルに下記マクロを登録 Sub 一括処理() Dim Fpath As String Dim Fname As String Dim Wb As Workbook Fpath = ThisWorkbook.Path & "\" Fname = Dir(Fpath & "*.xlsm") Do Until Fname = "" If Fname = ThisWorkbook.Name Then Else Application.DisplayAlerts = False 'ブックを開く Set Wb = Workbooks.Open(Fpath & Fname) 'マクロ実行 Application.Run "'" & Fname & "'!値貼り付け" Wb.Close SaveChanges:=True Application.DisplayAlerts = True End If Fname = Dir() Loop End Sub 一括処理の実行をすると、フォルダ内の一つのファイルだけ マクロ実行されると終了してしまいます。 各々のファイルには他にもマクロを登録していて、そちらは 'マクロ実行 Application.Run "'" & Fname & "'!値貼り付け" のマクロの名前部分を変更して、同様に一括処理していますが 問題なく動きます。 なぜかこの「値貼り付け」のマクロだけ全ファイルに動作して くれません。 色々自分なりに調べているのですが、どうしても原因不明で 今回投稿させて頂きました
- ベストアンサー
- Excel(エクセル)
- エクセルVBAでファイル保存失敗の原因?
エクセル2010です。 Sheets("DATA")にある822件のデータを、D列のデータ(担当者名)をキーにフィルター抽出し、雛形のシートにコピーして、そのシートを別ファイルとして名前をつけて、指定したフォルダーのサブフォルダに保存するマクロです。(サブフォルダ名はデータのG列にある文字列です。) キーとなる担当の数は223です。 以下のコードで一応作動するのですが、同じデータを使っても2回に一回くらいの割合で保存ができず、 wb(1).SaveAs Filename:=SaveDir & "\" & bcde & "_" & Trim(myC.Value) & ".xlsx" のところで止まってしまいます。 エラーは 「実行時エラー1004 SaveAsメソッドは失敗しました。Workbookオブジェクト」 というものです。このとき、画面上ではあたらしいファイルが出来あがっております。しかしその出来てるファイルを手動で保存しようと思っても、 「○○○(ファイル名)は保存中にエラーが検出されました。いくつかの機能を削除または修復することによりファイルを保存できる場合があります」 とでてしまいます。 まだテスト段階で、同一のデータでテストしているのですが、止まるデータは30件目であったり、140件目であったり、まちまちです。2回に1回くらいは最後まで動き、すべて正しく作成され保存できているので、データの問題ではないと思います。 ほかにどんな問題が考えられるのでしょうか?とても困っています。 Sub TEST20151114() Dim SaveDir As String, bcde As String, sbfdr As String Dim wb(1) As Workbook Dim i As Long, x As Long Dim myRng As Range, myC As Range Dim t t = Time Set wb(0) = ThisWorkbook Set myRng = wb(0).Sheets("担当別").Range("B2:B224") Application.ScreenUpdating = False For Each myC In myRng wb(0).Sheets("回答雛型").Copy After:=wb(0).Sheets("回答雛型") wb(0).Sheets("回答雛型 (2)").Name = "回答シート" With wb(0).Sheets("DATA") .AutoFilterMode = False .Range("A1:J1").AutoFilter .Range("A1:J1").AutoFilter Field:=4, Criteria1:=myC.Value 'D列 .Range("A2", .Range("A2").SpecialCells(xlLastCell)).SpecialCells(xlCellTypeVisible).Copy Sheets("回答シート").Range("A2") .ShowAllData x = wb(0).Sheets("回答シート").Cells(Rows.Count, "A").End(xlUp).Row .Range("A823:J827").Copy wb(0).Sheets("回答シート").Range("A" & x + 1) '予備5行追加 End With With wb(0).Sheets("回答シート") .Rows(x + 6 & ":" & .Rows.Count).Delete Shift:=xlUp Application.Goto Reference:=.Range("A1"), Scroll:=True bcde = CStr(Trim(.Range("E2").Value)) sbfdr = Trim(.Range("G2").Value) 'サブフォルダ名 .Move End With Set wb(1) = ActiveWorkbook SaveDir = wb(0).Path & "\20151114\" & sbfdr '保存先 If Dir(SaveDir, vbDirectory) = "" Then MkDir SaveDir '無ければサブフォルダ作成 End If DoEvents wb(1).SaveAs Filename:=SaveDir & "\" & bcde & "_" & Trim(myC.Value) & ".xlsx" wb(1).Close (False) myC.Offset(, 1).Value = x - 1 i = i + 1 Application.StatusBar = i & "/" & myC.Value Set wb(1) = Nothing Next myC Set wb(0) = Nothing Application.ScreenUpdating = True MsgBox i & "個のファイルを作成しました。" & vbCrLf & Format(Time - t, "hh:mm:ss") Application.StatusBar = "" End Sub
- ベストアンサー
- Excel(エクセル)
- VBA フォルダ内のファイル名一覧
下のようなコードですが、Dir("C:\見積\*.xls")の部分を このコードを書いてあるブックのあるフォルダの名前をもっと簡単に取得してコードにできないでしょうか。 もうひとつ付け加えたいこともあります。ファイル名一覧にする際、このブックと「XXX.xls」という名前のブック名以外の一覧にしたいのですが、これもお手上げですので、あわせてお願いします。 Sub test() Dim myFile As String Dim fl As Integer myFile = Dir("C:\見積\*.xls") fl = 9 Do While myFile <> "" fl = fl + 1 Cells(fl, 3).Value = myFile myFile = Dir() Loop End sub
- ベストアンサー
- オフィス系ソフト
お礼
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