• 締切済み

エクセルVBAで指定場所にフォルダー作成

エクセルのVBAマクロ機能を使い、 自動フォルダー作成&リンクするマクロを作成したのですが、 現在のマクロですと「A(仮名)」の中にフォルダーに作ってしまいますので 下記の様に階層で指定出来る様にしたいのですが、教えて頂けないでしょうか? 出来れば、そのままマクロ貼り付けで使える様にしたいので、 下記に途中までのマクロを編集して頂ければ助かります。 「A(仮名)」と言うフォルダーの中にエクセルファイルの管理表を入れ 「A」のフォルダーの中に「B(仮名)」と言うフォルダーを作り、 その中に管理台帳で自動作成されるフォルダーがつくられる様にしたい。 現在のマクロ Sub MakeHyLink() Dim wkStr As String If ActiveCell.Column <> 1 Then Exit Sub If ActiveCell.Value = "" Then MsgBox "アクティブセルは未入力、やり直し" Exit Sub End If wkStr = ThisWorkbook.path & "\" & ActiveCell.Value If Dir(wkStr, vbDirectory) = "" Then MsgBox "フォルダー:" & wkStr & vbLf & " を、作成します。" MkDir wkStr Else MsgBox "フォルダー:" & wkStr & vbLf & " は、存在します。" End If ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell, Address:=wkStr End Sub

noname#133464
noname#133464

みんなの回答

  • imogasi
  • ベストアンサー率27% (4737/17068)
回答No.1

フォルダを作成はMkdir(DOSコマンド由来)やCreateFolder(VBScript)やその他がありますが、質問にそれらが出てこないのはどうしてですか・ Googleででも「VBA フォルダ作成」で沢山記事とコードが出るのに、WEB照会もしないで、他人にコードをつくってくれと言わんばかりの依頼では無いですか(質問ではない)。 ーー フォルダやファイルを作る場所は文字列で指定する場合が多く(プログラムコードではこれしかない) (ドライブコード):(Aフォルダ名)¥((フォルダの中の)Bフォルダ名)¥・・・と書いて位置を調節すれば思うところにフォルダが作成される。 質問者のいう「階層構造」の辿り方や、そのパスの書き方だけの問題でしょう。 ファイルはフォルダを指定して、エクセルファイルであれば実際の内容を作成して、保存するか、空(内容が余りない初期状態の)ブックを名前をつけて書き出せば良い。 ーー ウインドウでマウスで選択指定して指定して行くやり方もある。 VBA フォルダ作成 ダイアロウグ VBAでWEB照会。 ーー ハイパーリンクは操作をして、マクロの記録を採ればわかる。 初心者のやるべきことをしてないと思う。WEBや本で調べる。マクロの記録を採れないか調べるの2点です。

関連するQ&A

  • フォルダー内のファイルとリンクするマクロVBA

    エクセルのマクロ機能を使い、エクセルのセルに管理番号入力し選択してマクロ実行すると、 自動でセルに入力した管理番号と同じフォルダー名の物を指定した場所に作成し、ハイパーリンクするVBAを 見よう見まねで作成しました。 この作成したVBAに追加機能を付けたいのですが、 WEBで検索したのですが、なかなか実行したい事が合う内容のものが見つからず、 マクロ初心者で何をどうすれば良いのか解りません。 大変申し訳ありませんが、どなたか教えて頂けませんでしょうか? 追加したい機能は、例としてA列の4と5の行を結合(結合しない場合もある)して管理番号を入力し、 自動で管理番号名のと同じフォルダーを作成しハイパーリンクした後に、 手動で、作成したフォルダーの中にファイルを入れる。 その後、行に同じファイル名を入力し、その行を選択してファイル名が同じ物があればハイパーリンクする様にしたい。 添付の画像ですと、管理番号を付けるのはA列で順番に番号を付けていきます。 1つのフォルダーの中に複数ファイルを入れる場合は、列を結合して1つの管理番号にし、 同じ行に並ぶフォルダーのE列(列の場所は変わる場合もあり)にフォルダーの中のファイル名を入力して、 フォルダー内同期リンク実行ボタンを押してファイルをハイパーリンクしたい。 ※管理番号で列に対し行は1:1の時もあれば、ファイルの数により、列を結合し1:2~1:10以上もある。 ※自動で管理番号名のと同じフォルダーを作成しハイパーリンクするVBAは下記で作ったのですが、   それをWEBで、似た様な内容のものを少し参考に編集しると、現在の機能も使えなくなってしまったりと困っています。   難しい。 Sub MakeHyLink() Dim wkStr As String If ActiveCell.Column <> 1 Then Exit Sub If ActiveCell.Value = "" Then MsgBox "アクティブセルは未入力、やり直し" Exit Sub End If wkStr = ThisWorkbook.path & "\TEST\" & ActiveCell.Value If Dir(wkStr, vbDirectory) = "" Then MsgBox "フォルダー:" & wkStr & vbLf & " を、作成します。" MkDir wkStr Else MsgBox "フォルダー:" & wkStr & vbLf & " は、存在します。" End If ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell, Address:=wkStr End Sub

  • エクセルVBAシート分けしても他のシート反映しない

    エクセルのVBAで、エクセルのセル(A列)に「12345」と入力しカーソールを入力したセルに合わせ、 今回作成したマクロを実行すると「12345」の名前がついたフォルダーを 指定した場所に自動作成しハイパーリンクするVBAを作成したのですが、 作ったVBAを同じエクセルでシート分けして、シート毎に作成されるフォルダー先を変更設定しても VBAのシート1で変えた場所にしか反映されません。 シート1は「ABC」にフォルダーを作る様にしたいのでVBAのシート1の保存先を「ABC」に設定 シート2は「DEF」にフォルダーを作る様にしたいのでVBAのシート1の保存先を「DEF」に設定 上記を設定した後にエクセルのシート2でマクロ実行しても「ABC」フォルダーの中に作ってしまう。 VBAの内容が変なのでしょうか? それともエクセルの仕様なのでしょうか? エクセルのバージョンは2003です。 検索等をしても特にHITしなくて・・・ 申し訳ありませんが、解る方いらっしゃいませんでしょうか? 保存先指定は下記、VBAの編集で可能。 「wkStr = ThisWorkbook.path & "\" & ActiveCell.Value」の「"\"」のところです。 例:ABCフォルダーの場合 「wkStr = ThisWorkbook.path & "\ABC\" & ActiveCell.Value」 現在のマクロ Sub MakeHyLink() Dim wkStr As String If ActiveCell.Column <> 1 Then Exit Sub If ActiveCell.Value = "" Then MsgBox "アクティブセルは未入力、やり直し" Exit Sub End If wkStr = ThisWorkbook.path & "\" & ActiveCell.Value If Dir(wkStr, vbDirectory) = "" Then MsgBox "フォルダー:" & wkStr & vbLf & " を、作成します。" MkDir wkStr Else MsgBox "フォルダー:" & wkStr & vbLf & " は、存在します。" End If ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell, Address:=wkStr End Sub

  • エクセルVBA自動ハイパーリンクフォルダー指定場所

    管理台帳を作成したく、下記のVBAを作りました。 マクロ内容は、Aセルに管理番号を入力しマクロ実行ボタンにて、 入力した番号と同じフォルダーを作成しハイパーリンクする自動フォルダー作成&ハイパーリンクマクロです。 現在のフォルダー作成場所はローカルのDドライブ直下に作る様に指定しているのですが、 エクセルVBAがある場所と同じ場所に、上記のマクロで作るフォルダーが出来る様にしたいのですが、 見よう見まねでVBAを何とか作ったのですが、知識がなくこれ以上が解りません。 出来れば、下記のVBAを編集して頂、教えて頂いたVBAをそのままコピペすれば使える状態で教えて頂ければ助かります。 宜しくお願い致します。 Sub MakeHyLink() Const path As String = "D:\" Dim wkStr As String If ActiveCell.Column = 1 Then wkStr = path & ActiveCell.Value If Dir(wkStr, vbDirectory) = vbNullString Then MsgBox wkStr & "フォルダがありません。作成します。" MkDir wkStr Else MsgBox wkStr & "フォルダは存在します。" End If ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell, Address:=wkStr End If

  • 検索後のセルの選択を正しくしたい

    Excel2007でマクロ作成中の初心者です。 以下のコードの中で(1)のところがうまく作動できません。 ここの ActiveCell.Select を正常にするにはどうしたらよいかご教示をお願いします。 Sub 最終日の検索() Dim FC As Range Dim mydate As Date mydate = Range("BQ5").Value For Each FC In Range("BR30:BR300") If FC.Value = DateValue(mydate) Then Exit For End If Next If FC Is Nothing Then MsgBox "みつかりませんここでおわりです" Exit Sub End If MsgBox "見つかりました" & vbLf & FC.Address(0, 0) & vbLf & FC.Value ' ' ここに処理を追加したい ActiveCell.Select ’----------(1) Selection.Offset(0, 45).Select ActiveCell.Select 貼付けしてあるかどうか Set FC = Nothing End Sub ---------------------------------- Sub 貼付けしてあるかどうか() If ActiveCell.Value = "※※" Then MsgBox " 既に貼付けしてあります" Else MsgBox "貼付けしてないので処理します" End If End Sub

  • マクロにおける条件文の作成の件

    以下の様に条件付きの計算式を作成しました。CommandButton3を押しても 計算しなかったり、TextBox3.Value > TextBox1 ではないときでもエラー メッセージが出ます。どこに欠点があるのか教えて下さい。 Private Sub CommandButton3_Click() Dim row As Integer If TextBox1.Value = Empty Then MsgBox ("Aが空欄です") Exit Sub End If If TextBox2.Value = Empty Then MsgBox ("Bが空欄です") Exit Sub End If If TextBox3.Value = Empty Then MsgBox ("Cが空欄です") Exit Sub End If If TextBox4.Value = Empty Then MsgBox ("Dが空欄です") Exit Sub End If If TextBox3.Value > TextBox1.Value Then MsgBox ("Cの値をAの値より小さくしましょう!") Exit Sub End If If TextBox4.Value > TextBox2.Value Then MsgBox ("Dの値をBの値より小さくしましょう!") Exit Sub End If TextBox5 = Round(TextBox1 * TextBox2 - (TextBox1 - TextBox3) * (TextBox2 - TextBox4) / 2, 0) End Sub

  • エクセルVBAでフォルダの作成-2

    先ほどダブルクリックすると、クリックしたその名前にしたフォルダを作成して、ハイパーリンクを設定する、ということで質問させていただき、良い回答を頂き質問を閉じましたが、また質問があります。 A列をクリックするとイベントを発生させるのを、 A4セルから、その下のデータが入っているセルまで をイベントが有効な範囲にしたいと思い、考えています。 「If Target.Column = 1 Then」の部分がそれだと思い、 If Target.Range("A4", Range("A" & Rows.Count).End(xlUp)) Then のように考えて実行しましたが、これはダメでした。 このように限られた範囲に変更すにはどのようにすればいいでしょうか? Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Const path As String = "D:\TEMP\倉庫\" Dim wkStr As String  If Target.Column = 1 Then   wkStr = path & Target.Value   If Dir(wkStr, vbDirectory) = vbNullString Then    MsgBox wkStr & "フォルダがありません。作成します。"    MkDir wkStr   Else    MsgBox wkStr & "フォルダは存在します。"   End If   ActiveSheet.Hyperlinks.Add Anchor:=Target, Address:=wkStr  End If End Sub

  • フォルダー内のファイルのリンク VBA

    以前、カーソールを置いた部分のテキストとフォルダーの中にあるファイルが一致した場合、 ボタンを押す事によりハイパーリンクを付けるVBAを教えて頂き、現在も活用をさせて頂いています。 今までエクセル「E」列を対象にしていたのですが、 使用しているうちに前列に項目を入れたくなり「E」列の前に2列追加し、 対象の列が「E」列から「G」列の変更になりました。 それから新たにリンクを作成しようとしても実行出来なくなりました。 追加した前列を消しても駄目に。 素人なりに列を指定しているところを変えてみたのですが駄目でして。 If .Column <> 5 Or .Value = "" Then Exit Subを If .Column <> 7 Or .Value = "" Then Exit Subに。 列を変えた場合は、何処をどうすれば良いのでしょうか? 申し訳ありませんが、教えて頂けないでしょうか? 元のVBA Sub Test() Dim fName As String fName = ThisWorkbook.path & "\test\test-a\" With ActiveCell If .Column <> 5 Or .Value = "" Then Exit Sub fName = fName & .Offset(0, -4).MergeArea.Cells(1, 1).Value & _ "\" & .Value & ".prt" If Dir(fName) <> "" Then ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell, Address:=fName End If End With End Sub

  • 列幅、行の高さを指定するマクロ

    元マクロ初心者(今はほとんど忘れています)です。 列幅、行の高さを変更するマクロを以前作りました。 セルに指定する列幅を入力するのですが、 最近100以上の値の時はスキップされることに気づきました。 100以上の値でも処理されるようにするにはどうすればよいでしょうか。 Sub 列幅変更マクロ() ' ' Macro1 Macro ' マクロ記録日 : 2004/1/31 ユーザー名 : ' 列幅の変更 ' Keyboard Shortcut: Ctrl+l ' If MsgBox("→:列幅を変更します。右の方向にセル内の数値に従って処理しています。一番右のセルに半角で「@」を終わりの印として入力してください。", vbOK) = 1 Then Do Until ActiveCell.Value = "@" If ActiveCell.Value < 100 Then If ActiveCell.Value > 0 Then Selection.ColumnWidth = ActiveCell.Value End If End If ActiveCell.Offset(0, 1).Select Loop End If End Sub Sub 行の高さ変更マクロ() ' ' Macro2 Macro ' マクロ記録日 : 2004/2/1 ユーザー名 : ' 行の高さ変更 ' Keyboard Shortcut: Ctrl+p ' If MsgBox("↓:行の高さを変更します。下の方向にセル内の数値に従って処理しています。一番下のセルに半角で「@」を終わりの印として入力してください。", vbOK) = 1 Then Do Until ActiveCell.Value = "@" If ActiveCell.Value < 100 Then If ActiveCell.Value > 0 Then Selection.RowHeight = ActiveCell.Value End If End If ActiveCell.Offset(1, 0).Select Loop End If End Sub

  • 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

  • エクセルVBAで無限ループ

    教えてください。 以下の2つのエクセルマクロはまったく同じことをさせようとしているのですが、test02の方は.Offset(1).Activateが働かないのか、無限ループに陥ってしまいます。 単にActiveCell.という記述をWith~End Withでまとめただけなのになぜこうなるのでしょうか? Sub test01() ActiveSheet.Cells(1, 1).Activate Do While ActiveCell.Value <> "" If Not IsNumeric(ActiveCell.Value) Then ActiveCell.Offset(0, 1).Value = "文字" ElseIf ActiveCell.Value > 0 Then ActiveCell.Offset(0, 1).Value = "正数" ElseIf ActiveCell.Value < 0 Then ActiveCell.Offset(0, 1).Value = "負数" Else ActiveCell.Offset(0, 1).Value = "その他" End If ActiveCell.Offset(1).Activate i = i + 1 Application.StatusBar = i Loop End Sub Sub test02() ActiveSheet.Cells(1, 1).Activate With ActiveCell Do While .Value <> "" If Not IsNumeric(.Value) Then .Offset(0, 1).Value = "文字" ElseIf .Value > 0 Then .Offset(0, 1).Value = "正数" ElseIf ActiveCell.Value < 0 Then .Offset(0, 1).Value = "負数" Else .Offset(0, 1).Value = "その他" End If .Offset(1).Activate i = i + 1 Application.StatusBar = i Loop End With End Sub

専門家に質問してみよう