エクセルVBAでフォルダの作成方法
- エクセルVBAを使用して、特定のセルをクリックしたときにフォルダを作成し、ハイパーリンクを設定する方法について質問があります。
- A列の特定のセルをクリックしたときにイベントを発生させ、下のセルにデータが入っている範囲内で有効にする方法を教えてください。
- 上記のVBAコードを使用してフォルダの作成とハイパーリンクの設定を行っているが、限られた範囲内で実行する方法がわからない。範囲を制限する方法を教えてください。
- ベストアンサー
エクセル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
- 4k3s4r3
- お礼率66% (76/114)
- オフィス系ソフト
- 回答数1
- ありがとう数2
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
＞A4セルから、その下のデータが入っているセルまで これは、セルＡ４以下のデータの入力されてるセルを処理する、ということと同じなので、、、 '----------------------------------------------- If Target.Column = 1 And Target.Row > 3 And Target.Value <>"" Then Cancel = True '●ふつうこれを入れる '------------------------------------------------- Cancel = True がある場合とない場合で実行してみてください。 それが必須なことがわかります。 以上。
関連するQ&A
- エクセル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
- 締切済み
- オフィス系ソフト
- エクセルVBAでフォルダの作成
こんにちは。 セルA4から下に商品番号が書いてあります。 その商品番号をダブルクリックすると、「専用のフォルダをつくりますか？」とメッセージを出して、「はい」であれば、 (1)商品番号を名前にしたフォルダを作成 (2)その商品番号のフォルダへのハイパーリンクを設定 というようにしたいと思っています。 調べ、調べ下のように書いているのですか、 (1)、(2)の肝心の部分が分かりません。 あと、A列のどんな行でもダブルクリックするとメッセージが出るので、A4以降の商品番号のある行まで、というようにできればいいとも思っています。 お教えいただけないでしょうか。宜しくお願いします。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, Columns("A")) Is Nothing Then myMSG = "専用フォルダをつくりますか？" If MsgBox(myMSG, vbYesNo + vbQuestion, "フォルダ作成") = vbYes Then '以下に '(1)「倉庫」フォルダにクリックしたA列の商品番号を名前にしたフォルダ作成 '(2)つくったフォルダへのハイパーリンクを設定 End If End If End Sub
- ベストアンサー
- オフィス系ソフト
- エクセル VBA について
エクセルで、 ダブルクリックしたら"*"を表示したい範囲に【入力】という名前をつけ、 ダブルクリックしたら９つ左のセルの内容を表示したい範囲に【金額】という名前をつけ、 二つの構文？をVisual Basicに作成したんですが、エラーが出てしまいます。 ひとつずつだと上手くいくのですが、なぜでしょうか？ わかる方教えてください。 あと申し訳ないのですが、VBAはまったくわからないため、ネット上で構文をコピーして貼り付けました。 そんな者でもわかる修正の説明をお願いいたします。 以下が作成し、エラーとなってしまう構文です。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Const RangeName As String = "金額" If Target.Value = "" Then Target.Value = Target.Offset(0, -9).Value Cancel = True End If End Sub Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Const RangeName As String = "入力" If Not Intersect(Range(RangeName), Target) Is Nothing Then Cancel = True If Target = "*" Then Target = "" Else Target = "*" End If End If End Sub
- 締切済み
- Windows系OS
- エクセルVBAのイベントで質問です。
ダブルクリックイベントで、G12:G31の範囲の文字列をB10:B27の範囲(最下行)に入れていくものを使っていますが、新たにH12:H31にある文字列もダブルクリックするとC10:C27の範囲(最下行)に入れていけるようにしたいと思います。 どのようにすればいいでしょうか。 ご存知の方いらっしゃればお教えいただけると助かります。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, _ Cancel As Boolean) Dim i As Long Dim flg As Boolean If Intersect(Target, Range("G12:G31")) Is Nothing Then Exit Sub If IsEmpty(Target.Value) Then Exit Sub With Worksheets("シートＡ") For i = 10 To 27 If .Range("B" & i).Value = "" Then .Range("B" & i).Value = Target.Value flg = True Exit For End If Next i If flg = False Then MsgBox .Name & " がいっぱいです。" End If End With Cancel = True End Sub
- ベストアンサー
- オフィス系ソフト
- Excel VBA で1時的に右クリックを使いたい
30枚ほどのシートの表を一挙に変更したいです。ところが、各シートに次のコードが入っているため、右クリックしてコピーとか一切使えません。各シートの変更ができるまで、右クリック使いたいです。何か方法ありませんでしょうか？ ' 画面の一番上表示 Dim hr As Range Set hr = Range("A1") '左上隅セルを設定 ActiveWindow.ScrollRow = hr.Row '行の一番上にスクロール ActiveWindow.ScrollColumn = hr.Column '列の一番左にスクロール End Sub Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Cancel = True 'プロシージャ終了後に表示されるショートカットメニューの非表示 If Target.Row > 14 And Target.Row < 45 And Target.Column > 13 And Target.Column < 15 Then 明細入力フォーム.Show End If If Target.Row > 36 And Target.Row < 45 And Target.Column > 1 And Target.Column < 3 Then Call ShowCalendarFromRange2(Target) End If If Target.Row > 36 And Target.Row < 45 And Target.Column > 3 And Target.Column < 5 Then Call ShowCalendarFromRange2(Target) End If If Target.Row > 36 And Target.Row < 45 And Target.Column > 5 And Target.Column < 7 Then Call ShowCalendarFromRange2(Target) End If If Target.Row > 36 And Target.Row < 45 And Target.Column > 8 And Target.Column < 10 Then Call ShowCalendarFromRange2(Target) End If If Target.Row > 36 And Target.Row < 45 And Target.Column > 2 And Target.Column < 4 Then UserForm3.Show End If If Target.Row > 36 And Target.Row < 45 And Target.Column > 4 And Target.Column < 6 Then UserForm3.Show End If If Target.Row > 36 And Target.Row < 45 And Target.Column > 6 And Target.Column < 8 Then UserForm3.Show End If If Target.Row > 36 And Target.Row < 44 And Target.Column > 9 And Target.Column < 11 Then UserForm3.Show End If End Sub
- ベストアンサー
- Excel（エクセル）
- エクセル2003のVBAについて
次のコードのように、初めにクリックしたセルに、次にクリックしたセルの内容をコピーするVBAを書いたのですが、コピー先の列を、複数指定する方法がわかりません。 たとえば、C～O列（３～１５）のように指定できればと思っています。 このようなことは可能でしょうか？ ご教授いただけます方、よろしくお願い申し上げます。 -------------------------------------------------- Dim FrstCell As Range Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.MergeCells = False And Target.Count > 2 Then Exit Sub On Error Resume Next '想定しないエラーを無視 If Target.Cells(1) = "" Then If Target.Column <> 3 Then Exit Sub 'C列 コピー先 Set FrstCell = Target.Cells(1) Else If Target.Column <> 18 Then Exit Sub 'R列 コピー元 Target.Copy FrstCell.MergeArea End If On Error GoTo 0 'エラートラップ終了 End Sub
- ベストアンサー
- その他MS Office製品
- Excel VBA 入力規則
入力規則を利用して、３つのセルを連携させることを考えていますが、 不適合な値を張り付けらられた場合に拒否をする方法があるのでしょうか。 Private Sub Worksheet_Change(ByVal Target As Range) Dim ad As String Dim ma As Range Dim ma2 As Range Dim r As Range Dim r2 As Range Dim r3 As Range Dim r1 As Range Dim m As Long Dim m2 As Long Application.EnableEvents = False If Target = "" Then Range("F7").Validation.Delete Range("F7") = "" If Target.Address(0, 0) = "B7" Then Range("D7").Validation.Delete Range("D7") = "" End If GoTo EXIT_SUB End If With Worksheets("Sheet1") ad = "A4" Set r = .Range(ad) Set ma = r.MergeArea Set r1 = r.Offset(0, 1) m = Application.Match(Range("B7"), .Range(r1, .Cells(r.Row + ma.Count - 1, r1.Column)), 0) Set r2 = .Cells(r.Row + m - 1, r1.Column) Set ma2 = r2.MergeArea If Target.Address(0, 0) = "B7" Then If ma.MergeCells Then setValiS Target.Offset(0, 2), r2 Range("F7").Validation.Delete Target.Offset(0, 2) = "" Target.Offset(0, 4) = "" Else MsgBox "A列が連結されていません。" End If ElseIf Target.Address(0, 0) = "D7" Then Set r3 = r2.Offset(0, 1) m2 = Application.Match(Target, .Range(r3, .Cells(r2.Row + ma2.Count - 1, r3.Column)), 0) setValiS Target.Offset(0, 2), .Cells(r2.Row + m2 - 1, r3.Column) Target.Offset(0, 2) = "" End If End With EXIT_SUB: Application.EnableEvents = True End Sub Sub setVali2() Dim tc As Range Dim c As Range Set tc = Worksheets("登録").Range("D3") Set c = Worksheets("Sheet1").Range("C3") setValiS tc, c End Sub Sub setValiS(tc As Range, c As Range) Dim ss As String Debug.Print tc.Address, c.Address ss = getChildren(c) If ss > "" Then With tc.Validation .Delete .Add Type:=xlValidateList, Formula1:=getChildren(c) End With End If Worksheets("登録").Activate End Sub Function getChildren(c As Range) Dim c1 As Range Dim ss As String Dim s1 As String Worksheets("Sheet1").Activate ss = "" For Each c1 In c.MergeArea s1 = c1.Offset(0, 1) If s1 <> "" Then ss = ss & "," & s1 Next c1 If ss <> "" Then ss = Mid(ss, 2) Else MsgBox "データがありません！" End If getChildren = ss End Function Sub Outline() Dim CheckRow As Long Dim Moji As String Dim TopRow As Long Dim EndRow As Long With ActiveSheet .Range("A2").ClearOutline .Outline.SummaryRow = xlAbove CheckRow0 = .Range("A" & .Rows.Count).End(xlUp).Row CheckRow = CheckRow0 Do If Moji = "" Then Moji = .Cells(CheckRow, 1).Value EndRow = CheckRow ElseIf yy_mm(CDate(.Cells(CheckRow, 1).Value)) = yy_mm(CDate(Moji)) Then TopRow = CheckRow If TopRow = 1 Then .Rows(TopRow + 1 & ":" & EndRow).Rows.Group Exit Do End If Else .Rows(TopRow + 1 & ":" & EndRow).Rows.Group CheckRow = CheckRow + 1 Moji = "" End If CheckRow = CheckRow - 1 Loop Until CheckRow = 1 .Rows(CheckRow + 1 & ":" & EndRow).Rows.Group .Outline.ShowLevels RowLevels:=1 ExecuteExcel4Macro "SHOW.DETAIL(1," & CheckRow0 & ",TRUE)" End With End Sub Function yy_mm(d As Date) yy_mm = Format(d, "yy/mm") End Function
- 締切済み
- その他（プログラミング・開発）
- エクセルVBAについて
エクセルVBAについて 下ような、最初に選択したセルに、次に選択したセルをコピーするマクロを使用しています。 Dim Frstcell As Range Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.MergeCells = False And Target.Count > 1 Then Exit Sub On Error Resume Next 'エラーを無視 If Target.Column >= 5 And Target.Column <= 35 Then 'E:AIコピー先 Set Frstcell = Target.Cells(1) ElseIf Target.Column >= 45 And Target.Column <= 46 Then 'AS:ATコピー元 If Target.Cells(1).Value = "" Then Exit Sub Target.Copy Frstcell.MergeArea End If On Error GoTo 0 'エラートラップ終了 End Sub この場合、コピー元の枠線の書式も、コピー先にコピーされてしまうのですが、 書式なしでコピーするにはどうしたらよいでしょうか？ よい方法がありましたら、よろしくお願いいたします。
- ベストアンサー
- その他MS Office製品
- エクセルコードについて
エクセルコードについて Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Row >= 1 And Target.Row <= 10 And Target.Column >= 1 And Target.Column <= 10 Then If Target.Value = "○" Then Target.Value = "" Else Target.Value = "○" End If Cancel = True End If End Sub ではセルA1～J10ですが、これをA1～A10などに変更するのにはどのようにすればよろしいでしょうか。
- 締切済み
- その他（ビジネス・キャリア）
- エクセルＶＢＡで Cancel=Trueの使い方
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$A$1" Then Exit Sub Cancel = True MsgBox "キャンセルしました" End Sub Private Sub Worksheet_Deactivate() Cancel = True MsgBox "キャンセルしました" End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Cancel = True MsgBox "キャンセルしました" End Sub 以上のように使ってみましたが、どれも「キャンセルしました」とメッセージは出るものの、直前の操作（入力、シート切替、セル移動）はキャンセルされませんでした。 どこが間違っているのでしょうか？
- ベストアンサー
- オフィス系ソフト
お礼
onlyromさんこんばんは。そう記述するのですね。勉強になりました。ありがとうこざいました。