ACCESSのVBAでテンプレとなるxlsファイルを編集して保存する際にエラーメッセージが表示される

このQ&Aのポイント
  • ACCESSのVBAでテンプレとなるxlsファイルを開き、編集を完了してSaveAsメソッドで違う名前で保存したいが、パス名が存在しないまたは別プログラムで開かれているとエラーメッセージが表示される。どこがいけないのか?
  • VBAを使用してACCESSのテンプレとなるxlsファイルを開き、編集を行い別名で保存したい。しかし、パス名が存在しないか別のプログラムで開かれているためエラーメッセージが表示される。どの部分が間違っているのか教えてください。
  • ACCESSのVBAを使用してテンプレとなるxlsファイルを編集して別名で保存したいが、パス名が存在しないか別のプログラムで開かれているためエラーメッセージが表示される。どこを修正すれば良いのでしょうか?
回答を見る
  • ベストアンサー

ACCESSのVBAでテンプレとなるxlsファイルを開き、編集を完了し

ACCESSのVBAでテンプレとなるxlsファイルを開き、編集を完了してSaveAsメソッドで違う名前で保存したいのですが、以下のコーディングではパス名が存在しないor別プログラムで開かれているなどとエラーメッセージが表示されます。どこがいけないのでしょうか?   Dim oApp As Object Dim xlBook As Object Dim strWORK As String Dim i As Integer Dim strMDBPATH As String Dim strXLSFILE As String Dim strSaveFile As String 'Accessの起動位置を取得 strWORK = CurrentDb.Name '後ろから1文字単位で¥を探す For i = Len(strWORK) To 1 Step -1 If Mid(strWORK, i, 1) = "\" Then Exit For '¥だったら抜ける Next i 'D:\xxxx\yyyy\zzz.mdb --> D:\xxxx\yyyy\ にする strMDBPATH = Mid(strWORK, 1, i) 'Excelの元ファイルの名前を作成 D:\xxxx\yyyy\ + テンプレート.xls strXLSFILE = strMDBPATH & "回答票テンプレ.xls" Set oApp = CreateObject("Excel.Application") Set xlBook = oApp.Workbooks.Open(strXLSFILE) oApp.Visible = True 'Only XL 97 supports UserControl Property ' On Error Resume Next ' oApp.UserControl = True '回答票テンプレを開く ' oApp.Workbooks.Open FileName:=strXLSFILE oApp.Range("C10") = Me!起票日.Value oApp.Range("H10") = Me!所属部門.Value oApp.Range("P10") = Me!起票社員番号.Value oApp.Range("T10") = Me!起票社員名.Value oApp.Range("C17") = Me!対象システム.Value oApp.Range("K17") = Me!処理区分.Value oApp.Range("P17") = Me!対象画面.Value oApp.Range("C21") = Me!改修内容.Value oApp.Range("C38") = Me!回答日.Value oApp.Range("I38") = Me!回答社員名.Value oApp.Range("C43") = Me!回答内容.Value strSaveFile = Me!所属部門 & "_" & Me!起票日 & ".xls" xlBook.SaveAs FileName:=strMDBPATH & strSaveFile

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

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

ご存知かとは思いますが、Excelは共有ブックとか特別な手段を行わない限り、同一ブックを開くことができません。 >以下のコーディングではパス名が存在しないor別プログラムで開かれているなどとエラーメッセージが表示されます おそらくブックを開いたままプロセスにExcelが残っているのでは? タスクマネージャのプロセス一覧で確認してみましょう。 >テンプレとなるxls >Set xlBook = oApp.Workbooks.Open(strXLSFILE) 「ファイルを開いて別名で保存」 という処理も変えた方がよいと思います。 テンプレートを利用して、ワークブックを追加する方法 Set xlBook = oApp.Workbooks.Add(strXLSFILE)

anman0201
質問者

お礼

対応が遅れてすみません。 大変参考になりました。 ありがとうございます。

関連するQ&A

  • ACCESS2003で改修依頼管理ツールを作成しています。

    ACCESS2003で改修依頼管理ツールを作成しています。 改修依頼用の回答票を出力する際のことなんですが、 現在、回答票テンプレートをあらかじめ同フォルダ内に保存していて、 それをExcelAppで開き、回答内容テーブルのデータをそのままコピーして名前をつけて保存しています。 しかし、その方法だとすでに同じ名前のファイルが存在していると名前をつけて保存する際に、同ファイルにアクセスできませんとエラーが出ます。 デバッグしてみるとどうやらテンプレートを開く際に読取専用で開かれており、 それを編集して別名で保存しているため、作成したファイルも読取専用ファイルになっているため 2回目以降に同名で出力する際に同ファイルにアクセスできなくなっているのだと思います。 これを回避する方法を知っている方がいれば是非教えていただきたいです。 コードを見ていただくわかると思いますが保存名の定義が部署名&発行日付のため1日に2回以上同じ部署の回答票を発行する際に困っています。 一応コードも載せておきます。 'On Error GoTo Err_コマンド0_Click Dim xlApp As Object Dim xlBook As Object Dim strMDBPATH As String 'MDBの保存場所、フォルダー・ディレクトリ Dim strXLSFILE As String 'テンプレートファイルの名前、e:\xxx\yyyy\テンプレート.xls Dim strSaveFile As String strMDBPATH = GetCrtPath 'Excelの元ファイルの名前を作成 D:\xxxx\yyyy\ + テンプレート.xls strXLSFILE = strMDBPATH & "回答票テンプレ.xls" '変数にエクセルアプリケーションをセットして開く Set xlApp = CreateObject("Excel.Application") Set xlBook = xlApp.Workbooks.Open(FileName:=strXLSFILE, ReadOnly:=False) xlApp.Visible = True '回答票テンプレを開く ' xlApp.Workbooks.Open FileName:=strXLSFILE '回答票に回答内容をコピーする xlApp.Range("C10") = Me!起票日.Value xlApp.Range("H10") = Me!所属部門.Value xlApp.Range("P10") = Me!起票社員番号.Value xlApp.Range("T10") = Me!起票社員名.Value xlApp.Range("C17") = Me!対象システム.Value xlApp.Range("K17") = Me!処理区分.Value xlApp.Range("P17") = Me!対象画面.Value xlApp.Range("C21") = Me!改修内容.Value xlApp.Range("C38") = Me!回答日.Value xlApp.Range("I38") = Me!回答社員名.Value xlApp.Range("C43") = Me!回答内容.Value 'ファイル名に所属部門と回答日を付加する strSaveFile = "回答票_" & Me!所属部門 & "_" & Format(Me!起票日, "yyyymmdd") & ".xls" '名前を変更して保存 xlBook.SaveAs FileName:=strMDBPATH & strSaveFile 'テンプレートを終了 ' xlApp.Quit 'オブジェクトの開放 Set xlApp = Nothing Set xlBook = Nothing MsgBox "回答票を発行しました。", vbInformation Exit_コマンド0_Click: Exit Sub Err_コマンド0_Click: MsgBox Err.Description Resume Exit_コマンド0_Click End Sub

  • accessのデータをexcelに

    Office97使用のシステム管理初級者です。 accessのクエリーを利用して以下のようなシステムを作ろうと思っているのですが、行き詰っています。 (1) 特定のデータ(複数)を抽出 (2) 既に用意しているexcelの任意の位置にデータを移管 (3) excelのブックを別名にてフロッピーに保存 (1)は何とかできたのですが、(1)によって抽出できたデータを任意のexcelに移管する時、最初の1データしか移管できなくて困っています。(次のようなものです・・・。) Private Sub エクセル起動_Click() On Error GoTo Err_エクセル起動_Click Dim oApp As Object Set oApp = CreateObject("Excel.Application") oApp.Visible = True 'Only XL 97 supports UserControl Property On Error Resume Next oApp.UserControl = True oApp.Workbooks.Open FileName:="D:\****\123.xls" oApp.range("b4").Value = Me![1] oApp.range("c8").Value = Me![2] oApp.range("d8").Value = Me![3] oApp.range("e8").Value = Me![4] oApp.range("f8").Value = Me![5] oApp.range("g8").Value = Me![6] oApp.range("h8").Value = Me![7] oApp.range("i8").Value = Me![8] oApp.range("j8").Value = Me![9] Exit_エクセル起動_Click: Exit Sub Err_エクセル起動_Click: MsgBox Err.Description Resume Exit_エクセル起動_Click End Sub それぞれの行にズラーッとデータがきて、さらにそのexcelを別名にてフロッピーに保存したいのですが、どのようにすればいいのでしょうか? よろしくお願いします。

  • ACCESS2013のVBAで、EXCELを操作

    ご質問させて頂きます。 ACCESS2013のVBAで、EXCELを操作するために 下記のようにしています。 ------- Dim oApp As Object Dim oWkb As Object Dim oWks As Object Dim Rw As Integer Dim SQL As String Set oApp = CreateObject("Excel.Application") oApp.Visible = True oApp.DisplayAlerts = Flase '確認メッセージの非表示 ↓↓↓オートメーションエラー Set oWkb = oApp.Workbooks.Open(CurrentProject.Path & "\ひながた.xls") ------- 上記のところでオートメーションエラーになってしまいます。 しかし私の端末ではエラーは出ません。 問題と思われるのは エラーが出る人の端末は、 EXCELが2010と2013と 2つのバージョンがインストールされていることです。 このようなことでエラーが出てしまうことはあるのでしょうか?

  • 開いているXLSファイルが読み取り専用か調べる

    Dim xlApp As Excel.Application Dim xlBook As Excel.Workbook Dim xlSheet As Excel.Worksheet Set xlApp = CreateObject("Excel.Application") Set xlBook = xlApp.Workbooks.Open("C:\test.xls") Set xlSheet = xlBook.Worksheets(1) 開いたExcelファイルが読み取り専用になっているかどうかを調べるにはどうすればいいですか? ファイルの属性が読み取り専用かどうかは取得できるのですが、属性は読み取り専用ではなくても誰か他のユーザーがネットワークから開いているために読み取り専用で開いている場合もわかるようにしたいです。 お願いします。

  • ACCESSのVBAにてExcelのシートをコピーしたい

    入庫.xlsに現在、"原紙"というシートがあります。 入庫.xlsには、"原紙"と入庫のあった日のシートがあるようにしたいのです。 今日、入庫があれば、入庫.xlsには "原紙"と"20"のシートが存在するようにしたいのです。 AccessのVBAにて1文でシートのコピーってできないでしょうか? Dim oApp As Object Dim StWk1 As String Dim SHizk As String Dim Hizk As Integer Hizk = DatePart("d", Me![入庫日付]) SHizk = CStr(Hizk) StWk1 = "c:入庫.xls" Set Xls = GetObject(StWk1) Xls.Application.Windows(1).Visible = True Xls.Application.worksheets("原紙").Copy After:=Xls.Application.worksheets(SHizk) Xls.Application.worksheets(SHizk).Activate 上記のように作成してみたのですが、実行すると、 Xls.Application.worksheets("原紙").Copy After:=Xls.Application.worksheets(SHizk) のところで、エラーになります。 実行エラー'9': インデックスが有効範囲にありません。 のメッセージが表示されます。 教えてください。

  • Excel VBAファイルがない場合メッセージ表示

    ExcelVBAでプログラムを実行させたときに2つのファイルを参照します。  (1)結果コピー先ファイル  (2)データ元ファイル この2つのファイルのうち、いずれかがなかった場合にメッセージを表示させたいのですが思うように表示されません。 以下のように動作させたいのですがうまくいきません。  (1)2種類のファイルがないときには両方のメッセージを   1つの画面に表示したい。  (2)どちらか一方のファイルがないときには、   エラーメッセージを表示させエラーのないファイルを   表示させない。    ※いろいろ試したら(a)がないメッセージが表示されたが、     (b)のファイルが表示された。  (3)正常に処理が終了した場合は、完了メッセージを表示したい。 途中まで書いてみたコードは以下の通りです。  ※実行コードは中略します。 '////////////////////////////////////////////////////// Sub test1() Dim sMsg As String Dim sMyDir As String sMyDir = ThisWorkbook.Path & "\" Dim Ws As Worksheet Dim vTgYear As Variant Dim Wb As Workbook Set Wb = Workbooks("算出プログラム.xls") Set Ws = Wb.Sheets("入力内容") vTgYear = Ws.Range("D17").Value With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim sWbkName As String, StName As String Dim wbk結果1 As Variant sWbkName = "3_結果\結果.xls"   StName = "Sheet1" Dim sWbkSubName As String sWbkSubName = "1_算定表\" & vTgYear & "_算定表.xls" Dim Kname As String, Mname As String Kname = sMyDir & sWbkName Mname = sMyDir & sWbkSubName Dim buf As String On Error GoTo myError Open sMyDir & "3_結果\結果.xls" For Input As #1 Line Input #1, buf Close #1 On Error GoTo ErrorHandler2 If Dir(Mname) <> "" Then Workbooks.Open Filename:=Mname, Password:="aaaaa" Else Dim Wb1 As Workbook Set Wb1 = Workbooks("結果.xls") Set wbk結果 = Wb1.Sheets(StName) Dim wbkA As Variant Dim sShtName As String sShtName = "地域1" Dim Wb2 As Workbook Set Wb2 = Workbooks(vTgYear & "_算定表.xls") Set wbk地域A = Wb2.Sheets(sShtName) wbk結果.Range("F9:N9").Value = wbk地域A.Range("AB7:AK7").Value wbk結果.Range("F10:N10").Value = wbk地域A.Range("AB51:AK51").Value wbk結果.Range("F11:N11").Value = wbk地域A.Range("AB95:AK95").Value wbk結果.Range("F12:N12").Value = wbk地域A.Range("AB139:AK139").Value wbk結果.Range("F13:N13").Value = wbk地域A.Range("AB183:AK183").Value wbk結果.Range("F14:N14").Value = wbk地域A.Range("AB227:AK227").Value wbk結果.Range("F15:N15").Value = wbk地域A.Range("AB271:AK271").Value wbk結果.Range("F16:N16").Value = wbk地域A.Range("AB315:AK315").Value ≪後略≫ Application.DisplayAlerts = False wbk結果1.SaveAs Filename:=sMyDir & "3_結果\" & vTgYear & "_テスト.xls" ' Application.DisplayAlerts = True With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With Workbooks(vTgYear & "_算定表.xls").Close SaveChanges:=False MsgBox "計算期間" & "「" & kenko_Label_10 & "」で" & vbLf & "ファイルを作成しました。", vbInformation Close #1 Exit Sub myError: MsgBox "出力先の「結果_健康寿命」ファイルが存在しません。" & _ vbLf & "処理を終了します。", vbOKOnly + vbExclamation Exit Sub ErrorHandler2: MsgBox "指定年の「長野県健康寿命算定表」" & _ vbLf & "ファイルが存在しません。処理を終了します。", vbOKOnly + vbExclamation End If End Sub '////////////////////////////////////////////////////// メッセージ画面以外は正常に動作することを確認しています。 メッセージ画面について教えてください。 素人で申し訳ありませんが、よろしくお願い致します。

  • VB2005でエクセルの機能を使うには

    VB2005でエクセルに数値を貼り付けた後自動的に エクセルの機能を使ってA列で並び替えをしたいのですが可能でしょうか。 今のソース s1()の配列に数値がはいっている。 exp s1(1)="1.0,2.0,3.0,4.0......" Dim xlApp As New Excel.Application Dim xlBooks As Excel.Workbooks = xlApp.Workbooks Dim xlFilePath As String = Application.StartupPath & "\aaa.xls" Dim xlBook As Excel.Workbook = xlBooks.Open(xlFilePath) Dim xlSheets As Excel.Sheets = xlBook.Worksheets Dim xlSheet As Excel.Worksheet = xlSheets.Item(1) ':::::::::::::::::::::::::::::::::::::::::::::::sheet1 '-----貼り付け開始 Dim xlRange As Excel.Range Dim xlCells As Excel.Range Dim xlRange1 As Excel.Range xlCells = xlSheet.Cells Dim j Dim Col As String For i = 1 To irec - 1 temp = Split(s1(i), ",") For j = 0 To 12 xlRange1 = xlCells(3 + i, 1 + j) Col = xlRange1.Address(False, False) xlRange = xlSheet.Range(Col) xlRange.Value = temp(j) Next j Next i ここで並び替えしたいのですが。

  • アクセスへのエクセルファイルの一括取込みについて

    お世話になっております。 エクセルVBAで所定のフォルダのエクセルファイルから一つのシートにまとめるというマクロを作成しております。アクセスVBAでaccdbファイルで同じことをしたいのですが、アクセスは触ったことがなく、ご教示していただけないでしょうか。 以下エクセルでの取り込みマクロです(長いので一部割愛)。 ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー Sub エクセル取り込み() Dim fpath, fname, buzai, bmst, hantei As String Dim buzaiflg As Boolean Dim wb As Workbook Dim sh1, sh2, sh3, sh4, sh5 As Worksheet Dim dlg As FileDialog Dim TCht As Chart Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set sh1 = ThisWorkbook.Worksheets("データまとめ") Set dlg = Application.FileDialog(msoFileDialogFolderPicker) ' キャンセルボタンクリック時にマクロを終了 If dlg.Show = False Then Exit Sub ' フォルダーのフルパスを変数に格納 fpath = dlg.SelectedItems(1) & "\" Application.DisplayAlerts = False i = 5 pcnt = 2 fname = Dir(fpath & "*.xl*", vbNormal) Do Until fname = "" Set wb = Workbooks.Open(fpath & fname, UpdateLinks:=0) Set sh2 = wb.Worksheets(1) i = i + 1 sh1.Range("A" & i).Value = i - 5 sh1.Range("B" & i).Value = fname sh1.Range("C" & i).Value = sh2.Range("A6").Value sh1.Range("D" & i).Value = sh2.Range("D6").Value sh1.Range("E" & i).Value = sh2.Range("F6").Value sh1.Range("F" & i).Value = sh2.Range("K4").Value sh1.Range("G" & i).Value = sh2.Range("K5").Value sh1.Range("H" & i).Value = sh2.Range("A9").Value 割愛 wb.Close SaveChanges:=False fname = Dir() Loop Application.ScreenUpdating = True Application.DisplayAlerts = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True MsgBox "終了しました。" End Sub

  • ACCESSとEXCELの連携について

    ACCESSとEXCELの連携について教えてください。 メインフォームA(単票)の中にサブフォームB(単票)があり、更にサブフォームB(単票)の中にサブフォーム(メインからみると孫フォーム)C(帳票)があるという構成のフォームがあります。各フォームにはそれぞれテキストボックスtext_X,text_Y,text_Zがあり、メインフォームにコマンドボタンQがあります。いま、このコマンドボタンQをクリックすることによってtext_X,text_Y,text_Zの内容をEXCELの特定ファイルの特定セル(例えばL1、M1、N1~10)に反映させたいと思っているのですが、メインフォーム(A)にあるtext_Xとサブフォーム(B)にあるtext_YはEXCELのセル(L1、M1)に取り込むことができるのですが、孫フォーム(C)にあるtext_Zをセル(N1~10)に反映させることが出来ません。text_Zはフォームが帳票フォームであることからLOOPを使っています。コマンドボタンQのクリック時のイベントでコードの書き方が違っているらしいのです。VBAは全く素人の手探り状態です。どなたか、素人でもわかるように教えていただけたら幸いです。よろしくお願い致します。 具体的には次のようなものです。(一部抜粋) Private Sub コマンド145_Click() Dim oApp As Object Dim rs As DAO.Recordset Dim i As Long Set rs = Me!営業入力SF.Form.RecordsetClone Set rs = 担当(1)F.Form.RecordsetClone Set oApp = CreateObject("Excel.Application") oApp.Visible = True 'Only XL 97 supports UserControl Property On Error Resume Next oApp.UserControl = True '指定のエクセルファイルを開く oApp.Workbooks.Open Filename:="I:\再出発!\受注票.xlt" 'エクセルファイルへデータセットする oApp.Range("名称").Value = Me![名称] oApp.Range("住所").Value = Me![住所] oApp.Range("パンフ送付").Value = Forms![営業F]![営業入力SF]![パンフ送付日] oApp.Range("DVD送付").Value = Forms![営業F]![営業入力SF]![DVD送付日] oApp.Range("正式見積書").Value = Forms![営業F]![営業入力SF]![正式見積書送付日] oApp.Range("契約書送付").Value = Forms![営業F]![営業入力SF]![契約完了日] 'サブフォームの内容をエクスポートする i = 11 Do Until rs.EOF oApp.Range("J" & Format(i)).Value = rs!テキスト1 oApp.Range("L" & Format(i)).Value = rs!テキスト4 i = i + 1 rs.MoveNext Loop Set rs = Nothing Exit_コマンド145_Click: Exit Sub Err_コマンド145_Click: MsgBox Err.Description Resume Exit_コマンド145_Click End Sub (WINDOWS XP    ACCESS 2002  EXCEL 2002 を使用)

  • vba ファイルの移動について

    フォルダAの中にあるたくさんのpdfファイルの中から、 ファイル名の頭文字3つがE列に記載した「aaa」だったら フォルダBに移動させるという内容にしたいです。 ネット検索などで、近いものを作成しましたが(下に貼り付け)、 下から4行目、「fso.moveFile FolderA & "\" & fileName, FolderB & "\" & fileName」で 「実行時エラー'53'  ファイルが見つかりません。」 とエラーが出てしまいます。 どの様に書き直せばよいのでしょうか? どなたかご存じでしたら、ぜひお教え下さい。 よろしくお願いします。 エクセル2010を使用しています。 Sub CheckAndMoveFiles() Dim FolderA As String Dim FolderB As String FolderA = Range("D1").Value FolderB = Range("B2").Value Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim ws As Worksheet Set ws = ActiveSheet Dim lastRow As Long lastRow = ws.Range("E" & Rows.Count).End(xlUp).Row Dim r As Long Dim fileName As String For r = 1 To lastRow If ws.Cells(r, "E").Value <> "" Then fileName = ws.Cells(r, "E").Value dFileName = Dir(FolderA & "\" & Left(fileName, 3) & "*.pdf") Do While dFileName <> "" dFileName = Dir() Loop fso.moveFile FolderA & "\" & fileName, FolderB & "\" & fileName 'ここでストップ End If Next End Sub

専門家に質問してみよう