• 締切済み

【VBA】ExecuteExcel4Macro

こんにちは、VBA初心者につき皆様のお知恵をお貸し下さい。 ExecuteExcel4Macroを使用し同一フォルダ内の複数ブックから値の取得を行う際に 特定のブックが開かれている（使用中）場合、それを判断する方法はありますでしょうか？ 当初は以下プログラムで判断していたのですが ファイル数が多い為１つ１つ開いてしまうととても処理時間が掛かるので 試行錯誤しながらExecuteExcel4Macroにたどり着きました。 ------------------------------------------------------------------------------------------- Set wb = Workbooks.Open(myFdr & "\" & fname) 　If ActiveWorkbook.ReadOnly Then 　　MsgBox "取得できませんでした" 　　ActiveWorkbook.Close 　　Exit Sub 　End If -------------------------------------------------------------------------------------------- 処理速度が早く出来るのであればExecuteExcel4Macroに拘りは無いので もし他にいい手段がありましたらご教授頂けると幸いです。 以上、宜しくお願い致します。

みんなの回答

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

下記の下段の手順などご参考に。 http://officetanaka.net/excel/vba/tips/tips108.htm

  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. その他MS Office製品

関連する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

  • VBAでのExecuteExcel4Macroの値取得でエラー

    こんにちは。 Excel VBAより、ExecuteExcel4Macroを実行して、 外部のExcelファイルの、名前（店名、月度）を定義したセルの値を取得したいと思っています。 店名：文字列型 月度：Date型 そこで、ExecuteExcel4Macro()を実行し、以下のような処理を加えました。 ------------------------------------------------------------------------------------ dim 店名 as Variant, 月度 as Variant If 外部マクロ実行("'c:\[test.xls]出勤簿'!店名", 店名) = False Or _ 外部マクロ実行("'c:\[test.xls]出勤簿'!月度", 月度) = False Then MsgBox "取得失敗", vbExclamation End End If Public Function 外部マクロ実行(com As String, ByRef result As Variant) As Boolean On Error GoTo erron3 result = ExecuteExcel4Macro(com) On Error GoTo 0 外部マクロ実行 = True Exit Function erron3: 外部マクロ実行 = False End Function ------------------------------------------------------------------------------------ これを実行したところ、「月度」の値は取得できるのですが、 「店名」の値には「エラー 2042」という値が入ります。 ※dirname, filenameは正しい値が入っています。 ※シート「出勤簿」および「月度」「店名」のセル名の定義も存在します。 test.xlsを開いてるときは、上記の現象は起こらず、 「店名」の値は正常に取得できます。 また、試しに、test.xlsを開き、 Worksheets("出勤簿").Range("店名")を実行すると、正常な値が取得できました。 まとめると、 ・閉じたブックの、あるシートにある、セルに定義された名前を指定して ・ExecuteExcel4Macroで、文字列が入っている値を取得しようとした時、 ・正常に値が取得できない という現象に遭遇しています。 3日ほど調べているのですが、どうしても原因が分かりません。 解決策をお持ちの方、いらっしゃいましたらアドバイスを頂けると助かります。 環境：WindowsXP Pro SP3 Excel 2003 (11.5612.5606) 以上、よろしくお願いいたします。

  • ExecuteExcel4Macroを使ったレコードの読み込み方法につ

    ExecuteExcel4Macroを使ったレコードの読み込み方法について 下記サンプルは、ファイルを指定して、指定したファイルの中にあるシートを選択し、その中にあるデータを読込むものになっています。 読込ませるファイルのsheet1には、『 ID，顧客番号，氏名，住所，電話番号 』 が入っています。 下記サンプルでは、顧客番号フィールドのデータは読込めるのですが、該当するレコード全体を読込むにはどう組み立てればいいかよくわかりません。 すみませんが、どなたかご教授いただけませんでしょうか。よろしくお願いいたします。 Public Sub testes() ' 変数の指定 Dim OpenFileName, SheetName, Target, buf As String Dim i, TargetCol As Long, GetNames() ' 対象ブックの選択 OpenFileName = Application.GetOpenFilename("Microsoft Excel ブック,*.xls") If OpenFileName = "False" Then Exit Sub ' ファイル名に[]を付ける OpenFileName = Replace(OpenFileName, Dir(OpenFileName), "[" & Dir(OpenFileName) & "]") ' 対象ワークシート名の指定と取得 SheetName = InputBox("対象ワークシート名を入力します") If SheetName = "" Then Exit Sub Target = "'" & OpenFileName & SheetName & "'!" ' ワークシートの正誤チェック On Error Resume Next buf = ExecuteExcel4Macro(Target & "R1C1") If Err <> 0 Then MsgBox "ワークシート [ " & SheetName & " ] を読めませんので終了します。", vbExclamation Exit Sub End If On Error GoTo 0 ' [顧客番号]フィールドを探す For i = 1 To 256 If ExecuteExcel4Macro(Target & "R1C" & i) = "顧客番号" Then TargetCol = i Exit For End If Next i If TargetCol = 0 Then MsgBox "[顧客番号]フィールドが確認できません。", vbExclamation Exit Sub End If ' データの読み込み For i = 1 To 10000 buf = ExecuteExcel4Macro(Target & "R" & i) If buf = "0" Then Exit For ' シートに出力する Worksheets("sheet3").Activate ActiveSheet.Cells(i, 1) = buf Next i End Sub

  • Excel VBA ExecuteExcel4Macroについて

    こんにちは。よろしくお願いします。 あるフォルダ"D:\test"のなかに、４つのxlsファイル"o.xls"、"a.xls"、"b.xls"、"c.xls"があるとします。 使用するシート名は、それぞれo,a,b,c（ファイル名から".xls"を除いたもの）とします。 このとき"o.xls"を開いて、下記のマクロを実行すると、１行目にパス名、２行名にファイル名、３行目以下に（１列目は"a.xls"の、２列目は"b.xls"の、３列目は"c.xls"の）セルA3以下が読み込まれます。 たとえば、結果は添付の図のようになります。図がうまくアップできなかったらごめんなさい。 Sub sample1() Application.Calculation = xlManual Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next Worksheets("o").Cells.Clear Dim p As String, fn As String, fc As Long, i As Long, j As Long, d, e p = ActiveWorkbook.Path fn = Dir(p & "\" & "*.xls", 0) fc = 0 If fn <> "" Then fc = fc + 1 For j = 3 To 6 With Worksheets("o") .Cells(1, fc).Value = p & "\" & fn .Cells(2, fc).Value = fn d = ExecuteExcel4Macro("'" & p & "\[" & fn & "]" & Mid(fn, 1, Len(fn) - 4) & "'!R" & j & "C1") If d = 0 Or IsError(d) Then Exit For Else .Cells(j, fc) = d End If End With Next j End If Do fn = Dir() If fn <> "" Then fc = fc + 1 For i = 3 To 6 With Worksheets("o") .Cells(1, fc).Value = p & "\" & fn .Cells(2, fc).Value = fn e = ExecuteExcel4Macro("'" & p & "\[" & fn & "]" & Mid(fn, 1, Len(fn) - 4) & "'!R" & i & "C1") If e = 0 Or IsError(d) Then Exit For Else .Cells(i, fc) = e End If End With Next i Else Exit Do End If Loop Application.ScreenUpdating = True Application.DisplayAlerts = True Application.Calculation = xlAutomatic End Sub 上記の例は変数iとjが3から6までしか動きませんし、読み込むxlsファイルも３つしかありませんのですぐに終わりますが、実際には行やファイルがもっとたくさんあり、非常に時間がかかっています。そこで、 ExecuteExcel4Macro("'" & p & "\[" & fn & "]" & Mid(fn, 1, Len(fn) - 4) & "'!R" & i & "C1") を e = ExecuteExcel4Macro("'" & p & "\[" & fn & "]" & Mid(fn, 1, Len(fn) - 4) & "'!R3C1:R6C1") というような風にして、For～Nextも使用せず .range(Cells(3, fc),cells(6, fc)) = e というふうに範囲で読み込もうとしたのですがうまくいきません。 ExecuteExcel4Macroは範囲を読み込むことはできないのでしょうか？ 何とかして処理速度を上げたいのですが、どうすればよいでしょうか。

  • VBA（ExecuteExcel4Macro）を用いた検索ツール

    VBA（ExecuteExcel4Macro）を用いた検索ツール はじめまして。 当方Excel2007、winXPでの環境下でVBAを用いた検索ツールを作成しています。 検索対象のxlsファイルには1行目に郵便番号、氏名、住所の項目タイトル、2行目以降にデータが入力されています。 【現在の仕様】 検索対象のxlsファイルを選択→検索したい氏名（3つまで）を入力すると氏名列を順に検索し、該当した氏名のみをシートへ出力 【作りたい仕様】 検索対象のxlsファイルを選択→検索したい氏名（3つまで）を入力すると氏名列を順に検索し、該当した氏名の入力された行をシートへ出力 現在のソースは下記になりますが、どのように書き変えればいいのかが分からず困っています。 教えていただけたらと思います。よろしくお願いいたします。 ------------------------- （略） ''対象ブックを選択します OpenFileName = Application.GetOpenFilename("Microsoft Excel ブック,*.xls") If OpenFileName = "False" Then Exit Sub OpenFileName = Replace(OpenFileName, Dir(OpenFileName), "[" & Dir(OpenFileName) & "]") SheetName = InputBox("読み込むワークシート名を入力してください。") If SheetName = "" Then Exit Sub Target = "'" & OpenFileName & SheetName & "'!" On Error Resume Next buf = ExecuteExcel4Macro(Target & "R1C1") If Err <> 0 Then MsgBox "ワークシート [ " & SheetName & " ] を読めませんでした。", vbExclamation Exit Sub End If On Error GoTo 0 key1 = InputBox("検索したい氏名1を入力してください。") If key1 = "" Then Exit Sub End If key2 = InputBox("検索したい氏名2を入力してください。") If key2 = "" Then Else key3 = InputBox("検索したい氏名3を入力してください。") End If For i = 1 To 256 If ExecuteExcel4Macro(Target & "R1C" & i) = "名前" Then TargetCol = i Exit For End If Next i If TargetCol = 0 Then MsgBox "[ 名前 ]フィールドが見つかりません。", vbExclamation Exit Sub End If Dim clm As Integer For i = 2 To 10000 buf = ExecuteExcel4Macro(Target & "R" & i & "C" & Target If buf = "0" Then Exit For If buf = key1 Then Sheet3.Cells(w, 3) = buf w = w + 1 ReDim Preserve GetNames(i - 1) GetNames(i - 1) = buf ElseIf buf = key2 Then Sheet3.Cells(w, 3) = buf w = w + 1 ReDim Preserve GetNames(i - 1) GetNames(i - 1) = buf （略） -----------------

  • マクロで複数ブックのデータを一つのブックにコピー

    マクロ超初心者です。 1つのフォルダの中に複数のbook（sheetも複数）があります。 これを新しい1つのbookにまとめたいです。 sheetは「bookを開いた時に表示されるsheetだけ」を新しいbookにまとめたいです。 どなたかの回答に下記マクロがありました。 Sub consolid() Application.ScreenUpdating = False '画面更新を一時停止 Set mb = ThisWorkbook 'このコピー先ブックをmbとする。 myfdr = ThisWorkbook.Path fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索 Do Until fname = Empty '全て検索 If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。 wb.Worksheets.Copy After:=mb.Sheets(mb.Sheets.Count) 'コピーしてコピー先ブックの末尾に置く wb.Close '開いたブックを閉じる n = n + 1 'ブック数をカウント End If fname = Dir 'フォルダ内の次のExcelブックを検索 Loop '繰り返す Application.ScreenUpdating = True '画面更新一時停止を解除 MsgBox n & "件のブックをコピーしましました。" End Sub このマクロを使わせていただき、 これでいける！と思ったのですが、255文字以上のコピーが出来ません。 どのようにすればよいでしょうか？

  • VBA Excel処理の追加を２点教えてください

    Office2003(SP3) 以下は、昔、教えてもらったExcel VBAスクリプトで、よく使わせて もらってます。「C:\mybooks\」にあるxlsファイル（a001.xls、a002.xls、 a003.xls・・・・）を片っ端から開き、 1つのBookに束ねる動作をします。 これだけでも大変便利なのですが、もう少し改善いたしたく。 (1) 束ねられたBookのSheet名が、Sheet1、Sheet1 (2)、Sheet1 (3)、 Sheet1 (4)・・・　になってしまいます。そこで、ファイル名から拡張子を落 とした文字列をSheet名にセットする記述をご教示下さい。 (2) a001.xls、a002.xls、a003.xls・・・は、それぞれSheet1、Sheet2、 Sheet3を含みます。Sheet1だけが抜き取られてSheet2、Sheet3が残された大量 の残骸Bookが開きっぱなしになります。これら、保存せずに閉じる記述を追加 したいのですが。 よろしくお願い致します。 Sub OpenFiles() Dim i As Integer Dim wb As Workbook Dim fname Dim dirname As String ' i = 1 dirname = "C:\mybooks\" fname = Dir(dirname + "*.htm") If fname <> "" Then Do While fname <> "" If fname <> "." And fname <> ".." Then If i = 1 Then ' 最初のファイルを開く Workbooks.OpenText FileName:=dirname + fname Set wb = ActiveWorkbook ' 最初のファイルを新規ブックに複製して閉じる。 ActiveSheet.Copy wb.Close Set wb = ActiveWorkbook Else ' 2番目以降のファイルは複製した最初のファイルに追加 Workbooks.OpenText FileName:=dirname + fname ActiveSheet.Move After:=wb.Worksheets(wb.Worksheets.Count) End If i = i + 1 End If fname = Dir Loop Else MsgBox "検索条件を満たすファイルはありません。" End If Set wb = Nothing End Sub

  • Ｅｘｃｅｌ　マクロで複数ブックのデータを一つのブックにまとめる方法

    マクロ初心者です。 1つのフォルダの中に複数のbook（sheetも複数）があります。 これを新しい1つのbookにまとめたいです。 回答に下記マクロがありました。 Sub consolid() Application.ScreenUpdating = False '画面更新を一時停止 Set mb = ThisWorkbook 'このコピー先ブックをmbとする。 myfdr = ThisWorkbook.Path fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索 Do Until fname = Empty '全て検索 If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。 wb.Worksheets.Copy After:=mb.Sheets(mb.Sheets.Count) 'コピーしてコピー先ブックの末尾に置く wb.Close '開いたブックを閉じる n = n + 1 'ブック数をカウント End If fname = Dir 'フォルダ内の次のExcelブックを検索 Loop '繰り返す Application.ScreenUpdating = True '画面更新一時停止を解除 MsgBox n & "件のブックをコピーしましました。" End Sub これで使用した所マクロを実行する度に何度も同じシートが コピーされてしまいます。 できれば同じ名前のシートは上書きにしてマクロを何度も使用できるように【各BOOKは毎週更新されて私のフォルダに入ってきます】したいのですが そのような事は可能なのでしょうか？ どなたか分かる方教えてください。お願い致します。

  • Ｅｘｃｅｌ　マクロで複数ブックのデータを一つのブックにまとめる方法

    マクロ初心者です。 1つのフォルダの中に複数のbook（sheetも複数）があります。 これを新しい1つのbookにまとめたいです。 sheetは「bookを開いた時に表示されるsheetだけ」を新しいbookにまとめたいです。 どなたかの回答に下記マクロがありました。 Sub consolid() Application.ScreenUpdating = False '画面更新を一時停止 Set mb = ThisWorkbook 'このコピー先ブックをmbとする。 myfdr = ThisWorkbook.Path fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索 Do Until fname = Empty '全て検索 If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。 wb.Worksheets.Copy After:=mb.Sheets(mb.Sheets.Count) 'コピーしてコピー先ブックの末尾に置く wb.Close '開いたブックを閉じる n = n + 1 'ブック数をカウント End If fname = Dir 'フォルダ内の次のExcelブックを検索 Loop '繰り返す Application.ScreenUpdating = True '画面更新一時停止を解除 MsgBox n & "件のブックをコピーしましました。" End Sub 非常によかったのですが、これですと (1)全てのsheetがコピーされてしまいます。 (2)また、保存しますか？とbookごとに聞いてきます。 上記のマクロのどこを変更すれば、(1)(2)を解決できますでしょうか？ （エクセルは2002です） 以上、よろしくお願いします。

  • エクセル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)の１枚目のシートを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

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する