• ベストアンサー

VBA 開いているブックの場所

ExcelでVBAを利用して、フォルダ(c:\"VBA練習")に置いてあるExcleの内容を、開いているExcleに自動読取り作業をするために、下記のようなコードを記述しました。(正常に動作します) そこで、ご相談なのですが、現在は特定のフォルダ(c:\"VBA練習")にExcelを置かないと読み取りは実現しません。ですが、開いているBookが置いてある"場所"にあるExcelを読み取りたい場合、どのように書き換えれば宜しいでしょうか? ご教授いただけると助かります。宜しくお願いします。 -------------------------------------------------------------- Private Sub 読込ボタン_Click() Dim myDir As String, myName As String, myBook As Workbook Dim copydata As Range, GYO As Range Dim SH2 As Worksheet, SH1 As Worksheet Set SH2 = ThisWorkbook.Worksheets("情報シート") '集計用のブックがあるフォルダ名を指定 myDir = "C:\VBA練習" myName = Dir(myDir & "\" & "*.xls") Do While myName <> "" Set GYO = SH2.Range("A65536").End(xlUp).Offset(1) '(1)指定した名前のブックを開いて変数に格納する Set myBook = Workbooks.Open(Filename:=myDir & "\" & myName) '(2)転記元を取得する Set SH1 = myBook.Worksheets("回答内容") Set copydata = SH1.Range("Z1").Resize(100, 1) '(3)転記先に貼り付ける copydata.Copy GYO.PasteSpecial Paste:=xlPasteValues, Transpose:=True '(4)開いたブックを閉じる myBook.Close myName = Dir() Loop End Sub --------------------------------------------------------------

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

  • ベストアンサー
回答No.3

単にループ中に自分自身とおなじパスかをチェックすればいいのでは? >Do While myName <> "" の下に If myName <> ThisWorkbook.Name Then >myName = Dir() の上に End If

004532
質問者

お礼

ありがとうございます! とても綺麗に仕上がりました!!

その他の回答 (2)

  • n-jun
  • ベストアンサー率33% (959/2873)
回答No.2

myDir = ThisWorkbook.Path と言う事?

004532
質問者

お礼

myDir = ThisWorkbook.Path で読み込めました!!ありがとうございます!

回答No.1

ThisWorkbook.Path を使ってみては。

004532
質問者

お礼

myDir = ThisWorkbook.Path で読み込めました!ありがとうございます! 追加で宜しいでしょうか? 開いているブックも読み込みの対象になってしまうのですが、開いているブック自体は対象外にする場合はどのように記述したら宜しいのでしょうか? 宜しくお願いします。

関連するQ&A

  • VBA 簡潔なコードを書くために

    現在、下記のようなコード書いて利用しています。 このコードを他の人がに転用する時に、指定箇所さえ書き換えれば簡単に転用できる!と言うようにしたいのです。 例えば >Set myBook = Workbooks.Open(Filename:=myDir & "\" & myName) >Set Copydata = SH1.Range("Z1").Resize(100, 1) といった指定するような箇所(" "で囲った所)を先にまとめて定義しておくにはどう記述したらよいのでしょうか。 宜しくお願いします。 ------------------------------------------------------------- Private Sub 読込ボタン_Click() '他のBookからデータを転記するマクロ Dim SH2 As Worksheet, SH1 As Worksheet Dim GYO As Range, Copydata As Range Dim myDir As String, myName As String, myBook As Workbook Set SH2 = ThisWorkbook.Worksheets("情報シート") '集計用のBookがあるフォルダ名を指定(このBookを格納している場所) myDir = ThisWorkbook.Path '他Bookのファイル名を指定(*.xls) myName = Dir(myDir & "\" & "*.xls") Do While myName <> "" 'このBook以外を対象 If myName <> ThisWorkbook.Name Then '転記先[情報シート]の最終行を取得 Set GYO = SH2.Range("A65536").End(xlUp).Offset(1) '他のBookを開いて変数に格納 Set myBook = Workbooks.Open(Filename:=myDir & "\" & myName) '転記元を取得(Z列1行を基点に100行コピー) Set SH1 = myBook.Worksheets("回答内容") Set Copydata = SH1.Range("Z1").Resize(100, 1) '転記先の最終次行に転記(行列入替で貼付) Copydata.Copy GYO.PasteSpecial Paste:=xlPasteValues, Transpose:=True '開いた他Bookを閉じる myBook.Close End If myName = Dir() Loop End Sub -------------------------------------------------------------

  • 複数のブックからデータを転記するマクロについて

    こんにちは。 VBAの素人なのでネットや本などで自分なりに調べましたが、 どうにも解決できないので、ご教示いただけませんでしょうか。 複数のブックにある同一セル番地にある データを別のブックにまとめたいのですが、 ブック数が500程度あり、マクロでうまくできないか悩んでいます。  (1)転記元ブックを開く。  (2)転記元データをコピーする。  (3)転記先ファイルのセルに貼り付ける。  (4)転記元ブックを閉じる。 の繰り返しだと思うのですが、(2)ができず困っています。 ちなみに、500のブックとまとめるブックも同じフォルダにあります。 具体的には、転記元ブックは以下のような形で、A列に様々な温度のデータが縦に並んでいます。    A列   1行  温度  2行  27 ←ここのみ抽出したい 3行  28 4行  30 それぞれのブックのA2番地の温度データのみを抽出し、転記先ブックのA2からA500までまとめたい。 組んだマクロは以下です。 ------------------------------ Sub 特定フォルダ内ブックを並べ替えて転記() Dim myDir As String, myName As String, myBook As Workbook Dim motodata As Range, sakidata As Range   '集計用のブックがあるフォルダ名を指定 myDir = "D:\VBA練習" myName = Dir(myDir & "\" & "*.xls")   Do While myName <> ""   '↓転記先の最新レコード位置を取得する   Set sakidata = Range("A65536").End(xlUp).Offset(1)   '↓(1)指定した名前のブックを開いて変数に格納する  Set myBook = Workbooks.Open(Filename:=myDir & "\" & myName)   '↓(2)転記元を取得する   Set motodata = myBook.Range("A2")      '↓(3)転記先に貼り付ける   motodata.Copy sakidata   '↓(4)開いたブックを閉じる   myBook.Close  myName = Dir()  Loop End Sub ------------------------------ mybookというキーワードを使用して、A2セルデータをコピーする構文をご教示いただけませんでしょうか。 以上、長々となってしまいましたが、何卒アドバイスの程お願いいたします。

  • VBA 別シートの最終行に追記

    ExcelのSheet1で作成した表の一部項目を、Sheet2に一覧表としてまとめたいのです。 例えばSheet1にアンケート項目のような入力されていて、毎日使いまわします。 セルA1: 訪問日→固定     セルB1: (日付)→更新 セルA3: お客様指名→固定  セルB3: (氏名)→更新 使いまわすので、1度入力されたものは、Sheet2に一覧表として転記しておきたいのです。Sheet2の一覧表の最終行をみつけて追記していきたいです。 書いてみたのは以下の通り。 Private Sub 登録ボタン_Click() Dim SH1 As Worksheet, SH2 As Worksheet Dim GYO As Long Set SH1 = ThisWorkbook.Worksheets("回答内容") Set SH2 = ThisWorkbook.Worksheets("情報シート") ' Sheet2の最終行を取得 GYO = SH2.Range("$A$65536").End(xlUp).Row ' 最終行の次行を取得 If SH2.Cells(GYO, 1).Value <> "" Then GYO = GYO + 1  ' 現在の収容位置の下に転記 SH2.Cells(GYO, 1).Resize(1, 20).Value = SH1.Range("$c$2:$D$10").Value With SH1 .Range("A3").Copy Destination:=SH2.Range("A2") .Range("B3").Copy Destination:=SH2.Range("B2") End With End Sub 項目は飛び飛びのセルに入力されていて、それらをまとめて一覧表の1行にまとめたいと思っています。 ここでは例としてSheet1[A3][B3]セルをSheet2へ転記していますが、項目はもっといっぱいあります。 記載したコードで実行すると、1回目は転記されますが、2回目以降が追記されていきません。 ' 現在の収容位置の下に転記 のところに問題があると思っています。 全くの初心者が、コードを書くのには無理があると思いますが、どなたか教えていただけないでしょうか。宜しくお願いします。

  • エクセルのVBAの記述について

    VBAの記述についてなのですが、 Sub filter() Dim gyo As Long Dim ws1 As Worksheet Dim ws2 As Worksheet Dim ws3 As Worksheet Set ws1 = Worksheets("データ") Set ws2 = Worksheets("チーム") Application.ScreenUpdating = False ws2.Range("A4:BH30").Clear gyo = ws1.Range("A65536").End(xlUp).Row ws1.Activate With ws1.Range(Cells(4, 1), Cells(gyo, 6)) .AutoFilter Field:=1, Criteria1:="A" .SpecialCells(xlCellTypeVisible).Copy ws2.Range("A4") Selection.AutoFilter End With Application.ScreenUpdating = True End Sub ならプログラムははしるのですが、 14行目を .SpecialCells(xlCellTypeVisible).Copy ws2.Range(Cells(4, 1)) だと 「実行時エラー 1004 Rangeメソッドは失敗しました Worksheet オブジェクト」 とでるのですが、出来ないのでしょうか? Cells(4, 1)の1のところを変数にして変えていきたいのですが、よい方法はありますか。 よろしくお願いいたします。

  • エクセルVBAの転記について

    エクセル2013VBAで最終行を取得しての転記が上手くいきません。どのようにすれば良いかご教授ください。 簡単なサンプルを下記します。 Sub サンプル入力からのDBへの転記() Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim myRow As Long Set Sh1 = Worksheets("サンプル入力") Set Sh2 = Worksheets("サンプルDB") With Sh2 myRow = Range("A" & Rows.Count).End(xlUp).Row + 1 .Range("A" & myRow).Value = Sh1.Range("D4").Value .Range("B" & myRow).Value = Sh1.Range("F4").Value End With End Sub 入力内容を変えないテストでは (1)実行するとDBへの転記は問題なく出来ます。 (2)継続してマクロを実行しても問題なく転記が行われ、同じデータが蓄積されていきます。 入力内容を変更して引き続きマクロを実行すると挙動不審に陥ります。 現象としては (1)初めの行に何度も重ねて転記を行う。 (2)空白行を作り、その行に何度も転記を行ってしまう。 (3)空白行を作り、それ以降転記を実行し蓄積を行ってしまう。 入力シートには結合セル、リストを使用していますが、原因究明を行う中でこれが原因とは思えませんでした。 これがクリアできないと先に進めません。ぜひお力を貸してください。 宜しくお願い申し上げます。

  • ExcelVBAでの転記処理エラーについて

    ExcelVBAを使用して、データを転記集約させる作業をしたいと思っています。 詳しく言いますと、同一のフォルダ内に各店からの注文書のファイルを保存し(フォーマットは同じ)、それを集計用のファイルで、それぞれ入力してあるデータを読み込み一覧にしていくという作業です。 転記部分をサブルーチンにしています。 実行すると、最後の topRng.PasteSpecial xlPasteValues でエラーになり、「実行時エラー1004 この操作には同じサイズの結合セルが 必要です」とメッセージが出ます。 そこで結合セルを解除したのですが、同じメッセージが出てしまいます。 どこをどう修正すればよいのか、お教え頂けないでしょうか? 転記先のセルの開始位置の取得が間違っているのでしょうか? 宜しくお願いいたします。 Dim keyRng As Range Sub 集計開始() myDir = "D:\集計用" flg = 0 ChDir myDir MyName = Dir(myDir & "\*.xls") Do While MyName <> "" Set mybook = Workbooks.Open(MyName) Call 転記(mybook.Sheets(1).Range("D6"), flg) flg = 1 Application.DisplayAlerts = False mybook.Close Application.DisplayAlerts = True MyName = Dir Loop Application.ScreenUpdating = True MsgBox ("集計処理が終わりました") End If End Sub Sub 転記(myRng, mytitle) Set keyRng = Range("A1") If keyRng = "" And keyRng.Offset(1) = "" Then Set topRng = keyRng Else Set topRng = keyRng.End(xlDown).Offset(1) End If Set mytbl = myRng.CurrentRegion If mytitle = 1 Then Set mytbl = mytbl.Offset(1, 0).Resize(mytbl.Rows.Count - 1, mytbl.Columns.Count) End If mytbl.Copy topRng.PasteSpecial xlPasteValues End Sub

  • エクセル VBA データ入力

    こんにちは、はじめまして。 エクセル・VBA初心者です。 会社に入って3ヶ月になります。 同じファイル内で、入力用シートから 違うシートに表としてデータを転送するため、 本や今まで作ったものを参考にして下のようなVBAを作成したのですがうまくいきません。 Sub 転記() Dim ws0 As Worksheet, ws1 As Worksheet, chikuseki As Range Dim nyuryoku() Set ws0 = Worksheets("Worksheet1") Set ws1 = Worksheets("Worksheet2") nyuryoku = Array("b3", "d3", "f3", "h3") '転記したいセルの位置 Set chikuseki = ws1.Range("f", "g", "k", "q" & Rows.Count).End(xlUp).Offset(1) 'データ蓄積セル For i = 0 To UBound(nyuryoku) chikuseki.Offset(0, i).Value = ws0.Range(nyuryoku(i)).Value ws0.Range(nyuryoku(i)).MergeArea.ClearContents Next masgbox "入力完了" End Sub 十何個あるデータを転送する場合、フォームから入力した方が簡単なのでしょうか? また、表にデータを転記し、そのなかのデータのいくつかを別の表に転記することは、一度の操作で可能ですか? 今週中に仕上げろと言われたので急いでいます、 どうかよろしくお願いします。 質問がまとまっていなくてわかりにくければ申し訳ないです。

  • VBAでセルのコピーをすると、エラーになる

    =IF(COUNTIF('5月'!B4:I13,E13)=0,"",COUNTIF('5月'!I:I,E13))というセルを コピーして、別のシートのセルに貼り付けたのですが、値が「0」の場合「””」が セルに張り付いてしまい、その後の計算ができません。 「””」を本当の空欄にするにはどうしたらいいのでしょうか? Sub 転記() Dim sh1 As Worksheet Dim sh2 As Worksheet Dim SN As String SN = Month(Now()) Set sh1 = Sheets(SN) Set sh2 = Sheets("差出票") sh1.Range("A35").End(xlUp).Offset(1) = sh2.Range("B9") sh1.Range("A35").End(xlUp).Offset(0, 1) = sh2.Range("F13") sh1.Range("A35").End(xlUp).Offset(0, 2) = sh2.Range("F14") sh1.Range("A35").End(xlUp).Offset(0, 3) = sh2.Range("F15") sh1.Range("A35").End(xlUp).Offset(0, 4) = sh2.Range("F16") sh1.Range("A35").End(xlUp).Offset(0, 5) = sh2.Range("F17") sh1.Range("A35").End(xlUp).Offset(0, 6) = sh2.Range("F18") sh1.Range("A35").End(xlUp).Offset(0, 7) = sh2.Range("F19") End Sub

  • エクセルVBAのオートフィルタについて

    いつもお世話になります。 エクセル2007でVBAでオートフィルタを操作したいのですが、 一部うまくいきません。 以下の様なコードを書いて 日付で絞り込みたいのですが、 何も抽出されません。 リストを見てみると、変数はちゃんと入っており OK ボタンを押すとその日付で抽出されます。 何故VBAでの操作では抽出されないのでしょうか。 ご存じの方がおられましたら、よろしくお願いします。 Sub test() Dim mydate As Variant Dim rng3 As Range Dim fmt As Variant Dim objList3 As ListObject Dim wb1 As Workbook Dim wb2 As Workbook Dim wb4 As Workbook Dim sh1 As Worksheet Dim sh2 As Worksheet Dim sh3 As Worksheet Dim sh4 As Worksheet Dim sh7 As Worksheet '----------------------------------------------------------------------- Set wb1 = Workbooks("301.xlsm") Set wb2 = Workbooks("1.xls") Set wb4 = Workbooks("2.xls") Set sh1 = wb1.Worksheets("@") Set sh2 = wb1.Worksheets("@@") Set sh3 = wb2.Worksheets("@@@") Set sh4 = wb2.Worksheets("@@@@") Set sh7 = wb4.Worksheets("@@@@@") '---------------------------------------------------------- sh2.Range("A1:z63").ClearContents With sh7 Set objList3 = .ListObjects("リスト1") fmt = .Range("A2").NumberFormatLocal mydate = Format(mydate, fmt) objList3.Range.AutoFilter Field:=7, Criteria1:=mydate objList3.Range.AutoFilter Field:=5, Criteria1:="test" Set rng3 = objList3.Range.SpecialCells(xlCellTypeVisible) rng3.Copy sh2.Range("A2") objList3.Range.AutoFilter Field:=5 objList3.Range.AutoFilter Field:=5, Criteria1:=">=190" Set rng3 = objList3.Range.SpecialCells(xlCellTypeVisible) rng3.Copy sh2.Range("A20") objList3.Range.AutoFilter Field:=5 objList3.Range.AutoFilter Field:=7 End With Application.CutCopyMode = False Set rng3 = Nothing Set fmt = Nothing Set objList3 = Nothing Set wb1 = Nothing Set wb2 = Nothing Set wb4 = Nothing Set sh1 = Nothing Set sh2 = Nothing Set sh3 = Nothing Set sh4 = Nothing Set sh7 = Nothing End Sub (一部省略しています)

  • VBAのオブジェクト変数について

    人に教えなければいけないことなので、、、 困っています。 あるVBAのテキストを見て、そのテキストをそのまま入力しても実行できません。 (条件としては、Book1.xlsとBook2.xlsというファイルを開いた状態で、Book1.xlsのほうに、以下のモジュールを入力します。) Sub Set1() Dim myBook As Workbook Dim mySheet As Worksheet Dim myCell As Range Set myWBook = Workbooks("Book2.xls") Set myWSheet = Worksheets("Sheet2") Set myCell = Range("A1:D10") myWBook.Activate myWSheet.Activate myCell.Value = "ABC" End Sub これを実行すると、アクティブな状態のファイルにしか、値"ABC"が入ってこないのです。テキストでは、Book2.xlsのSheet2のA1:D10に値"ABC"が入ってくると言っていますが、Book1.xlsに値が入ってしまったりします。 長くなってしまってすみません。 もちろん、他の方法で実現することができるのはわかるのですが、なぜこのコードが実行できないのかがわかりません。 理由を教えていただけたら・・・と思います。 よろしくお願いいたします。

専門家に質問してみよう