• ベストアンサー
※ ChatGPTを利用し、要約された質問です(原文:ファイルを開くマクロで質問です)

ファイルを開くマクロで質問です

このQ&Aのポイント
  • セルC20にファイルのパスが入力されています。セルI9~I18 M9~M18でダブルクリックしたときにC20セルにあるパスをひらくにはどうしたらよいでしょうか?
  • C20のパスがすでに開いている時、エラーなどにならずにそのエクセルシートを開く方法はありますでしょうか?読み取り専用や、一度保存して閉じるとかではなくそのまま開いているシートにとびたいです。もしこれが無理であれば保存してとじて再度開き直す方法でも大丈夫です。
  • 開いたエクセルシートの【計測データ読み込み】という名前のシートのD列の一番下のデータをダブルクリックしたセルに貼り付ける方法も分かれば教えて下さい。

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

  • ベストアンサー
  • keithin
  • ベストアンサー率66% (5278/7940)
回答No.4

private sub WorkSheet_BeforeDoubleClick(byval Target as excel.range, Cancel as boolean)  dim myFile as string  if application.intersect(target, range("I9:I18,M9:M18")) is nothing then exit sub  cancel = true  myfile = range("C20").value  if dir(myfile) = "" then   msgbox "FILE NOT FOUND"   exit sub  end if ’開いていれば表に出す  on error goto errhandle  workbooks(dir(myfile)).activate  target.value = activesheet.range("D65536").end(xlup).value  exit sub errhandle: ’開いてなければ開く  workbooks.open myfile  resume end sub >このマクロの続きで こうやってダラダラといつまでもついでについでにのご相談が随分多いので、原則としてついでのご質問は回答しない事にしています。 続きのご質問に気持ちが行ってしまい、いつのまにか最初のご相談の解決が無かったことになってしまうのもイヤですしね。 当初の目的が果たせたら、このご相談はしっかり解決で一度閉じてから、新たなご質問内容は新しいご相談として「詳しい状況をキチンと添えて」別途投稿するようにしてください。 >開いたシートのD列の一番下のデータ 開いたのは「ブック」です。 そのブックの「どのシート」が今開いているかは、何も規定されていない事に留意してください。 それとも?シートの指定は全くしないまま、「成り行きで今開いている(不定の)シート」を無条件に対象にしてよかったのでしょうか。 >ダブルクリックしたセルに貼り付ける コピーして貼り付けなきゃいけないのか、それとも値を転記してくれば良いのか、どういう状況でしょうか。それによって適当なマクロの書き振りも変わってくる事に留意してください。

全文を見る
すると、全ての回答が全文表示されます。

その他の回答 (3)

  • chie65535
  • ベストアンサー率43% (8539/19413)
回答No.3

>セルI9~I18 M9~M18でダブルクリックしたときに >C20セルにあるパスをひらくにはどうしたらよいでしょうか? > 現在はどのセルでダブルクリックをしてもC20のパスが開いてしまいます。 適当な場所に If Target.Row < 9 Or Target.Row > 18 Or Target.Column < 12 Or Target.Column > 13 Then Exit Sub を入れる。 >またC20のパスがすでに開いている時、エラーなどにならずに >そのまま開いているシートにとびたいです。 MsgBox filepath & vbCrLf & "は既に開いています。" '★ を Workbooks(i).Activate にする。 あと、蛇足ですが If filepath = Workbooks(i).FullName Then は If Ucase(filepath) = UCase(Workbooks(i).FullName) Then にすべき。 このようにして「大文字小文字を区別しない」ようにしておかないと、大文字小文字を区別してしまって、既に開いているブックを「開いていないと判断してしまう」場合がある。

yyrd0421
質問者

補足

ありがとうございます。 まだまだ至らぬところだらけで、ネットで拾ってきたマクロをかき消ししてたので、めちゃくちゃなマクロですよね。すみません。 ご回答とアドバイスまで頂きありがとうございます。 このマクロの続きで開いたシートの列の一番下のデータを ダブルクリックしたセルに貼り付ける方法の方はお分かりになりますでしょうか?

全文を見る
すると、全ての回答が全文表示されます。
  • keithin
  • ベストアンサー率66% (5278/7940)
回答No.2

やりようは様々あると思いますが private sub WorkSheet_BeforeDoubleClick(byval Target as excel.range, Cancel as boolean)  dim myFile as string  if application.intersect(target, range("I9:I18,M9:M18")) is nothing then exit sub  cancel = true  myfile = range("C20").value  if dir(myfile) = "" then   msgbox "FILE NOT FOUND"   exit sub  end if ’開いていれば表に出す  on error goto errhandle  workbooks(dir(myfile)).activate  exit sub errhandle: ’開いてなければ開く  workbooks.open myfile end sub

yyrd0421
質問者

補足

昨日に引き続き、ご回答ありがとうございます。 目的が果たせました。 このマクロの続きで開いたシートのD列の一番下のデータを ダブルクリックしたセルに貼り付ける方法などはお分かりになりますでしょうか?

全文を見る
すると、全ての回答が全文表示されます。
  • takncom
  • ベストアンサー率16% (15/91)
回答No.1

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean) のあとに If Target.Row = 1 And Target.Column = 1 Then Exit Sub というようなのを入れて 指定したセル以外は、抜けるようにすればよいです。

yyrd0421
質問者

お礼

お礼が大変遅くなってしまい申し訳ありませんでした。 ありがとうございます。

全文を見る
すると、全ての回答が全文表示されます。

関連するQ&A

  • ファイルを検索するマクロで教えて下さい

    質問No.9060575で下記のような質問をさせて頂きました。 ↓↓↓↓↓↓↓↓ ファイルを選択するマクロを教えてください。 ブックAのシートA セルA1に100という数字が入力されています。 C:\Users\Documents のフォルダの中に シート選択#100.xlsm シート選択#101.xlsm シート選択#102.xlsm シート選択#103.xlsm シート選択#104.xlsm というシートがあるとします。 やりたいことはセルA1に数字が入力されている状態でマクロ実行ボタンを押した時 C:\Users\Documentsのフォルダの中にあるシート選択#100.xlsmのシートを開きたいです。 セルA1が101ならシート選択#101.xlsmを開く。 またセルA1になにも入力されていない場合はメッセージで [入力されていません] 入力されていてもフォルダ内に当てはまる番号がない場合は [ヒットするNo.がありません] みたいな感じでメッセージを表示したいです。 宜しくお願いします。 ↑↑↑↑↑↑↑↑ この質問で回答をもらい、解決できましたが ここにプラスαで、もしA2セルに999と入力されていて C:\Users\Documents のフォルダの中に シート選択#100#999.xlsm というシートや シート選択#101#995.xlsm というシートがある場合はどのようにすればよろしいでしょうか? 前回と同じく100や999の部分はランダムに変わります。 前回のベストアンサーを載せておきます。 ■VBAコード Sub file_open() Dim f_fmt As String, i As Integer '設定==============   Const dpath As String = "C:\Users\Documents\"   Const adr As String = "A1"   Const st As String = "シートA"   f_fmt = "#<NO>\シート選択#<NO>.xlsm" '==================   If Len(Range(adr).Value) = 0 Then MsgBox "入力されていません": Exit Sub   f_fmt = dpath & Replace(f_fmt, "<NO>", Range(adr).Value)   If Dir(f_fmt) = "" Then MsgBox "ヒットするNo.がありません": Exit Sub   Workbooks.Open Filename:=f_fmt   For i = 1 To Worksheets.Count     If Worksheets(i).Name = st Then       Worksheets(i).Activate       Exit Sub     End If   Next i   MsgBox "ワークブック """ & Dir(f_fmt) & """ に、ワークシート """ & st & """ が見つかりません" End Sub

  • エクセルマクロ フォルダ内のファイル検索で

    よろしくおねがいします。 下記で、どうも指定フォルダ内のファイル名を検索できていないようで 条件の"ないなら"に反応して中断するハズがファイルを開いてしまいます。 思ったのですが、bufの設定にファイル名は指定できないのでしょうか? Sub Start8() Dim buf As String, IptA As String Const Path As String = "C:\001\" IptA = Workbooks("AAA.xls").Sheets("Sheet1").Cells(1, 1).Value buf = Dir(Path & "" & IptA & ".txt") If buf = "" Then Range("A2").Select ActiveCell.FormulaR1C1 = "" & IptA & "は見つかりません" Exit Sub Else Range("A2").Select ActiveCell.FormulaR1C1 = "" & IptFN & "が見つかりました" End If Workbooks.OpenText Filename:= _ "C:\001\" & IptA & ".txt" End Sub

  • エクセル 2010 マクロ 検索

    http://okwave.jp/qa/q8562170.html 上記質問に追加です。 ※1 'D,E,F,G,H,I,K を検索してD,E,F,G,H,I に検索対象があった時 E,F,G,H,Iのいずれかだったら左横列の上に向かって (EならD 、FならE ・・・という具合に) 何か入力されているセルのM列の191000####をmsgboxで表示させたいです。 (画 F11セル(A-1)が検索ヒットした場合E9セル(R-01)を辿り、 その行のM列のセル(191000####)をmsgboxで表示 ※2 但し、検索結果がD列のデータだった時、その行のM列が191000####だった場合 M列の191000####をmsgboxで表示させたいです。 (画 D25セル(Y-1)対象の時) ※3 また、検索結果がD列のデータだった時、その行のM列が191000####以外だった場合 (空白だったり191000####以外の場合) M列の一番上の191000####をmsgboxで 191000####&「これは例外です」と表示させたいです。 (画 D24セル (X-1)対象の時) 現在のコードは下記のとおりです。 Sheet1に Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address <> "$A$3" Then Exit Sub Call 検索 Range("A1:A2").Clear Range("A1").Activate End Sub 標準モジュールに Sub 検索()  Dim Ws1 As Worksheet, Ws2 As Worksheet  Dim strKey As Variant  Dim s As String  Dim c As Range, bln As Boolean  Dim rng1 As Range  Dim cnt As Long    Set Ws1 = Sheet1  Set Ws2 = Sheet2    Ws1.Select    With Ws2   strKey = Application.Transpose(.Range("A1").Resize(2).Value)   strKey = Join(strKey, "")  End With    If Trim(strKey) = "" Then MsgBox "検索キーが空です", vbCritical: Exit Sub      With Ws1   Set rng1 = .Range("K2", .Cells(Rows.Count, "K").End(xlUp))   For Each c In rng1.Offset(, -10)     'D,E,F,G,H,I,Kを検索    s = c.Offset(0, 3).Value & c.Offset(0, 4).Value & c.Offset(0, 5).Value & c.Offset(0, 6).Value & c.Offset(0, 7).Value & c.Offset(0, 8).Value & c.Offset(0, 10).Value &        If StrComp(s, strKey, vbTextCompare) = 0 And c.Offset(0, 2).Value = "" Then     c.End(xlToRight).Activate c.Offset(0, 2).Value = Date          c.Resize(1, 14).Interior.ColorIndex = 6     bln = True     Exit For    End If   Next c      If Not bln Then    Ws2.Select    MsgBox "リストに存在しません", vbExclamation, "NotFound"   Else '加える    Call ReSearch(Ws1.Range("M2"), c.Row)    '再設定    Set rng1 = .Range("K6", .Cells(Rows.Count, "K").End(xlUp))    MsgBox "残り" & DoubleCountBlank(rng1.Offset(, -8), rng1) & "品目です。", vbInformation   End If  End With  Application.Goto Ws2.Range("A1"), True End Sub Sub ReSearch(Rng As Range, j As Long) '最初のセル, 終わりの行数 Dim i As Long Dim Ws As Worksheet With Rng.Parent For i = j To Rng.Row Step -1 If CStr(.Cells(i, Rng.Column).Value) Like "191000####" Then MsgBox "指図番号 " & vbCrLf & CStr(.Cells(i, Rng.Column).Value) & " の部品です" Exit For End If Next i End With End Sub Function DoubleCountBlank(rng1 As Range, rng2 As Range) '横並びのセルのブランクをカウントする (セル範囲1 , セル範囲2)  Dim i As Long  Dim cnt As Long  For i = 1 To rng1.Rows.Count   If VarType(rng2.Cells(i, 1)) = vbDouble Then    If rng1.Cells(i, 1).Value = "" And rng2.Cells(i, 1).Value <> 0 Then     cnt = cnt + 1    End If   End If  Next i  DoubleCountBlank = cnt End Function 宜しくお願い致します。

  • 2つのマクロを1つにしたい

    いつもお世話になっております。 今回もよろしくお願いいたします。 (1)14のシートがあるのですが、データーのある2から14までのシートを印刷する。 (2)上記のうち、c列のデーターで連続しているセルを結合する。 (1)と(2)を合わせて1つのマクロにしたいのですが、アクティブシート1つにしか(2)のマクロが動きません。 下記のコードの間違いを教えてください。 Sub 契約書目次印刷() Dim Sh As Worksheet Dim t As Long Dim i As Range t = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row 'データーのあるシートだけ印刷 For Each Sh In Worksheets(Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14)) If Sh.Range("A2").Value <> "" Then '連続データーセル結合 For Each i In Range("C1:C" & t) If i.MergeArea(1).Value = i.Offset(1).Value Then Range(i.MergeArea, i.Offset(1)).Merge End If Application.DisplayAlerts = False Next i End If Sh.PrintPreview Next Sh End Sub

  • マクロで色が同じになるように設定したい

    こんにちは。 現在マクロに挑戦中なのですが、一点分からず戸惑っています。 お分かりになる方教えてください。 下記のマクロを書きました。 Sheet2のセルに数字を入れることによってSheet1のセルの色が変わるようにしています。 25以上の数字は全て青(カラー番号5)表示にしたいのですが、どのように記したら良のか教えてください。 --------------------------------------------------------------- Private Sub Worksheet_Change(ByVal Target As Range) Dim iColors As Variant Dim i As Integer Dim j As Integer iColors = Array(36, 20, 24, 37, 40, 39, 17, 22, 45, 43, 28, 6, 4, 41, 18, 47, 50, 46, 10, 7, 3, 21, 9, 5) For Each c In Target If c.Value <> "" Then If IsNumeric(c.Value) Then i = c.Value If i > 0 And i < 25 Then j = iColors(i - 1) Else j = 2 End If End If End If i = c.Row If i > 2 And j > 0 Then Worksheets("Sheet1").Range("B3:K6").Cells(i - 3).Interior.ColorIndex = j End If Next c End Sub --------------------------------------------------------------- お分かりになる方、宜しくお願い致します。

  • マクロについて質問です。

    A B C   1 3 りんご 2  赤 3 くだもの 4 6 みかん 5 オレンジ 6 くだもの 7 9 ぶどう 8  紫 9 くだもの というデータがシート1にあったとして、シート2のa2セルに6と入力すると以下のようにa5セル以降に抽出し、6という入力を消すと抽出したものも消えるようなマクロ 6 みかん  オレンジ  くだもの 上のような質問で下のマクロを教えていただけたのですが、もし、みかんのb列も3だった場合いしたのようにみかんの行まで抽出できるようにするには下の構文をどうかえたらよいでしょうか。下手くそな質問ですがよろしくお願いします。 3 りんご   赤  くだもの  みかん  オレンジ  くだもの 現在、わかっている構文↓ Private Sub Worksheet_Change(ByVal Target As Range) 'この行から Dim c As Range, wS As Worksheet Set wS = Worksheets("Sheet1") With Target If .Address = "$A$2" Then If .Value <> "" Then Set c = wS.Range("B:B").Find(what:=.Value, LookIn:=xlValues, lookat:=xlWhole) If Not c Is Nothing Then c.Offset(, 1).Resize(3).Copy Range("A5") Else MsgBox "該当データなし" End If Else Range("A5").Resize(3).ClearContents End If End If End With End Sub 'この行まで

  • Excelのマクロで質問です

    セルに関数で文字が入った時にマクロを実行させる方法を教えて下さい。 今回行いたいのは、C9~C19セルにNGと表示された場合にメッセ―ジを表示したいです。 Private Sub Worksheet_Change(ByVal Target As Range) '変化のあったセルがA1セルか? If Intersect(Target, Range("C9:C19")) Is Nothing Then Exit Sub '条件判定:A1セルの値は 1 か? If Target.Value = "NG" Then MsgBox "NGです" End If End Sub このような場合C9~C19セルにNGと打ち込めばメッセ―ジが表示されるのですが あらかじめ、関数で =IF(M9="","",IF(Q9<M9,"OK","NG")) というような式がそれぞれのC9、C10、C11・・・・セルに入ってしまっています。 これだと、例えばC9セルにNGと表示されてもマクロは起動せず、メッセージが表示されません。 関数をマクロに盛り込むか、このままでもマクロが起動できるような書き方があるか 教えてください。 すみません。補足でQ9セルには =IF(I9="","",I9+"07:01")のような関数が 入力されています。

  • エクセルVBAで指定したセルへジャンプするコード(追加の追加質問です)

    http://oshiete1.goo.ne.jp/qa2903797.html たびたびすみません。最後にひとつだけお願いします。 お教えいただいた下のコードは順調に動作するのですが、 対象セルが結合セルの場合、エラーが出てしまいます。 とまってしまうコードの部分は With Selection.AddComment です。 エラーメッセージにはプロシージャの呼び出し、 または引数が不正です。(Error 5)と書いてあります。 結合セルは動作しないものでしょうか? Sub test01() Dim x As String Dim ThisSheet_Name As String Dim Sheet_Name As String Dim Range_Name As String Dim I As Integer, n As Integer Dim Ans As Integer Dim myComment As String '新規追加 Dim Colors As Integer '新規追加 ThisSheet_Name = ActiveSheet.Name '設定シート Select Case Workbooks.Count Case 1 MsgBox "チェックするファイルがありません。" Exit Sub Case 2 For n = 1 To 2 If Workbooks(n).Name <> ThisWorkbook.Name Then x = Workbooks(n).Name '開いている“もうひとつのブック”の名前 End If Next Case Else MsgBox "他に開いているファイルが複数のため対象を特定できません。" Exit Sub End Select I = 0 Do While (1) With ThisWorkbook.Sheets(ThisSheet_Name) If .Range("A3").Offset(I, 0).Value = "" Then MsgBox "検査項目は以上です。" ThisWorkbook.Activate Exit Do 'A列の3行目以下が、空白なら終わる End If Sheet_Name = .Range("A3").Offset(I, 0).Value Range_Name = .Range("B3").Offset(I, 0).Value myComment = .Range("C3").Offset(I, 0).Value End With Windows(x).Activate Sheets(Sheet_Name).Select Range(Range_Name).Select Colors = Selection.Interior.ColorIndex '新規追加 Selection.Interior.ColorIndex = 6 With Selection.AddComment .Visible = True .Text myComment End With Range(Range_Name).Select Ans = MsgBox("「次をチェックしますか?」", vbYesNo) Selection.Interior.ColorIndex = Colors '修正 Selection.ClearComments '新規追加 If Ans = vbYes Then I = I + 1 Else Exit Do End If Loop End Sub

  • 以前質問し解決した、セルを次々にジャンプについて又質問です。

    以前、こちらで別ブックの指定したセル番に飛んで、色付け、コメントを表示、次のセルへ飛ぶ際には色を元に戻し、コメントも取り去る。 というコードを教えていただきました。それは大変役に立ち、教えてくださった方々も何度もかかわっていただいた質問でした。 一年たって新たに問題が出たのでいろいろ構っていたのですが、また質問に参りました。 問題点は、下のコードを実行する際、検査する別ブックにシートの保護がかかっている場合エラーになることです。こればっかりは、そのブックのシート保護を解除しない限り無理でしょうか? シートの保護はかかっているのですが、飛んでいくセルには編集できるようになっているので、余計に残念です。 Sub oshiete() Dim x As String Dim ThisSheet_Name As String Dim Sheet_Name As String Dim Range_Name As String Dim i As Integer, n As Integer Dim Ans As Integer Dim myComment As String '新規追加 Dim Colors As Integer '新規追加 ThisSheet_Name = ActiveSheet.Name '設定シート Select Case Workbooks.Count Case 1 MsgBox "チェックするファイルがありません。" Exit Sub Case 2 For n = 1 To 2 If Workbooks(n).Name <> ThisWorkbook.Name Then x = Workbooks(n).Name '開いている“もうひとつのブック”の名前 End If Next Case Else MsgBox "他に開いているファイルが複数のため対象を特定できません。" Exit Sub End Select i = 0 Do While (1) With ThisWorkbook.Sheets(ThisSheet_Name) If .Range("A3").Offset(i, 0).Value = "" Then MsgBox "検査項目は以上です。" ThisWorkbook.Activate Exit Do 'A列の3行目以下が、空白なら終わる End If Sheet_Name = .Range("A3").Offset(i, 0).Value Range_Name = .Range("B3").Offset(i, 0).Value myComment = .Range("C3").Offset(i, 0).Value End With Windows(x).Activate Sheets(Sheet_Name).Select Range(Range_Name).Select Colors = Selection.Interior.ColorIndex '新規追加 Selection.Interior.ColorIndex = 6 With Selection(1).AddComment '選択範囲の1番目にコメント .Visible = True .Text myComment End With Range(Range_Name).Select Ans = MsgBox("「次をチェックしますか?」", vbYesNo) Selection.Interior.ColorIndex = Colors '修正 Selection.ClearComments '新規追加 If Ans = vbYes Then i = i + 1 Else Exit Do End If Loop End Sub

  • エクセルVBAの変数利用

    シートのC1セルに入力したブック名をアクティブにするための 変数なのですが、アクティブになりません。 下のようにしていますが、とのようにすればよいでしょうか? Sub test() Dim FileName As Range FileName = ThisWorkbook.Path & "\" & Sheets("sheet1").Range("C1") & ".xls" Workbooks.FileName.Activate End Sub

専門家に質問してみよう