AccessVBAから、「開いているExcelブック/シートを1つにまとめて保存」という処理を行いたい

Question

AccessVBAから、「開いているExcelブック/シートを1つにまとめて保存」という処理を行いたいです。

「AccessVBAでExcelを操作する」を参考にしつつ以下のようなコードを書いてみたのですが、「実行時エラー9:インデックスが有効範囲にありません」のエラーが出てしまいます。エラー箇所は、「For i = 2 to ExApp.Workbooks(ExApp.Workbooks.Count)」です。

以下のコードをどのように改善すれば、エラーを解消し想定通りの動きをすることが出来るのでしょうか？

Sub AccessVBAでExcelブックを1つにまとめて保存()

Dim ExApp As Object
Set ExApp = CreateObject("Excel.Application")
ExApp.Visible = True 'Excelの可視化

Dim DesktopPath As String, FilePath As String, WSH As Variant
Set WSH = CreateObject("Wscript.Shell")
DesktopPath = WSH.SpecialFolders("Desktop")
FilePath = DesktopPath & "\保存名.xlsx"

'メイン処理
Dim i As Integer

    '開いているExcelブック数を数えて、２個目以降のブックのSheets(1)を1個目のブックに追加して閉じていく
    For i = 2 to ExApp.Workbooks(ExApp.Workbooks.Count)
     ExApp.Workbooks(i).Worksheets(1).copy _
     Before:=ExApp.Workbooks(1).Sheets(1) 'ワークブック1にシートを追加してコピー
     ExApp.Workbooks(i).Close
    next i

    ExApp.Workbooks(1).SaveAs FileName:=FilePath
    ExApp.Workbooks(1).Close

ExApp.Quit

Set ExApp = Nothing
Set WSH = Nothing

MsgBox "完了しました。"

End Sub

追記：2021/01/11 15:30
事前にエクセルを開いているコードはこちらです。
標準モジュールに書いた以下のコードを、フォームのクリック時イベントで複数回よびだしてExcelブックを開いています。

Function ExcelData(frm As Form)
On Error GoTo Err_cmdExcel_Click
'DAOで抽出結果のクローンを作成
Dim xlsx As Object 'Excel.Applicationを代入するオブジェクト変数
Dim wkb As Object 'Excel.Wookbookを代入するオブジェクト変数
Dim rst As DAO.Recordset '現在のレコードセットを入れる変数
Dim idx As Long 'フィールド数変数
Dim j As Long ' 最終行取得用
Const xlUp As Integer = -4162

Set rst = Nothing 'データリストの初期化
Set rst = frm.RecordsetClone 'フォームのレコードセットのクローンを代入

'レコードが存在しない場合、処理を中止
If rst.BOF = True And rst.EOF = True Then
MsgBox "出力出来るデータがありません。", vbOKOnly + vbExclamation, "出力不可"
'レコードセットを閉じる
rst.Close: Set rst = Nothing
Exit Function
End If

'レコードが存在する場合、Excelに出力
'レコードセットの最初のデータにカーソルを移動
rst.MoveFirst

'Excelファイルを内部的に作成
Set xlsx = CreateObject("Excel.Application")
'作成されたExcelファイルにワークブックを追加
Set wkb = xlsx.Workbooks.Add()

'追加されたワークブックに、レコードセットのデータをコピー
With wkb.Worksheets(1)

For idx = 1 To rst.Fields.Count
.cells(1, idx).Value = rst.Fields(idx - 1).Name
Next

.Range("A2").CopyFromRecordset Data:=rst

'レコードセットを閉じる
rst.Close: Set rst = Nothing
'Excelデータを表示
xlsx.Visible = True
xlsx.UserControl = True
'メモリに展開されたExcel用オブジェクト変数を開放
Set wkb = Nothing
Set xlsx = Nothing

Exit_cmdExcel_Click:
Exit Function

Err_cmdExcel_Click:
MsgBox "エラーのため、Excelへ出力できません。" & vbCrLf & "一旦フォームを閉じ、再度トライしてください。" & vbCrLf & Err.Number & Err.Description, _
vbOKOnly + vbCritical, "Excel出力不可！"
Resume Exit_cmdExcel_Click
End Function

Comments

[退会済みユーザー]

いまソースを読み込んでるんですが、実際のソースはきちんとインデントされてるんですよね？

[NGK]

インデントとは、例えばIf構文を使った時に「If Else End」の文頭をそろえることで認識あっているでしょうか。その意味であっていれば、追記に記載したものはコピペでずれてしまいましたが、実際のソースではインデントをそろえているつもりです。(インデントがコードに影響することはあるのでしょうか、単に見やすくするためのものだと思っていたのですが)

[退会済みユーザー]

VBA ではインデントが実行に影響することはありませんが、可読性向上のためにインデントを揃えます。
で、お願いなのですが、CreateObject() → GetObject() に修正した最新ソースを提示していただけますか。
別途コメントしましたが、私の環境では umau さんのソースは正しく動作しましたので。

[NGK]

なるほど、今回は回答者様方の可読性のためにきちんとインデントまで整えるべきでした。甘えてしまい申し訳ありません。

理由は分からないのですが、一度PCを再起動したところ、私のPC環境でもきちんとumau さんのソースがただしく動作してくれました。こちら参考に、いったん自分の希望している動作も実行できないか試してみます。その後、再度追記にソースコードをアップさせていただきます。

[退会済みユーザー]

よろしくお願いします。

[hatena19]

ユーザーがエクセルを起動させて新規ブックを追加した場合は、umau さんのソースでも動作すると思いますが、Access VBAでCreateObject("Excel.Application")でエクセルを複数生成した場合はうまく動作しないと思います。その辺の切り分けを確認してください。

Answer 1

    '開いているExcelブック数を数えて、２個目以降のブックのSheets(1)を1個目のブックに追加して閉じていく
    For i = 2 to ExApp.Workbooks(ExApp.Workbooks.Count)

まず、上記の
For i = 2 to ExApp.Workbooks(ExApp.Workbooks.Count))
は下記に修正してください。
For i = 2 to ExApp.Workbooks.Count

ただし、提示のコードではワークブックを開くコードがないので、この時点では、ExApp.Workbooks.Count は 0 です。
ですので、Forループは実行されずには、次の、
ExApp.Workbooks(1).SaveAs FileName:=FilePath
で同様のエラーになりますね。

「開いているExcelブック/シートを1つにまとめて保存」の「開いている」というのは、どのように開いているのでしょうか。あるいは、開くのでしょうか。

ユーザーが既に手作業でいくつかのブックを開いておいて、それを対象とするでしょうか。
あるいは、特定のフォルダー内のブックを対象とするのでしょうか。
それとも、、、

その辺を明確に提示してください。

追記されたコードについて

CreateObject("Excel.Application")は新規のエクセルアプリケーションを生成します。
もし、これを繰り返す実行すると複数のエクセルアプリケーションが開いてしまいます。
（タスクマネージャーで確認してみてください。）
それぞれのWorkbooks.Add()で新規ブックを一つ開いていることになります。

下記の点を考慮してコーディングしてください。

• Dim xlsx As Object の宣言は標準モジュールの冒頭で宣言する。モジュールの冒頭だとモジュールの実行後自動解放されるので以降参照できない。また、モジュール内で解放しないようにする。
• CreateObject("Excel.Application")は最初の一回のみ実行する。複数のエクセルアプリケーションを開かないようにする。

上記を考慮すると、

Option Compare Database
Option Explicit

Dim xlsx As Object    'Excel.Applicationを代入するオブジェクト変数

Function ExcelData(frm As Form)
    On Error GoTo Err_cmdExcel_Click
    'DAOで抽出結果のクローンを作成
    Dim wkb As Object    'Excel.Wookbookを代入するオブジェクト変数
    Dim rst As DAO.Recordset    '現在のレコードセットを入れる変数
    Dim idx As Long    'フィールド数変数
    Dim j As Long    ' 最終行取得用
    Const xlUp As Integer = -4162

'****中略*****

    'Excelアプリケーションを生成(事前に生成されていない場合のみ)
    If xlsx Is Nothing Then
        Set xlsx = CreateObject("Excel.Application")
    End If
    
    'Excelアプリケーションにワークブックを追加
    Set wkb = xlsx.Workbooks.Add()

    '追加されたワークブックに、レコードセットのデータをコピー
    With wkb.Worksheets(1)

'****中略*****

        'Excelデータを表示
        xlsx.Visible = True
        xlsx.UserControl = True
        'メモリに展開されたExcel用オブジェクト変数は解放しない 
        'Set wkb = Nothing
        'Set xlsx = Nothing
    End With

'****中略*****

End Function

Sub AccessVBAでExcelブックを1つにまとめて保存()

    If xlsx Is Nothing Then
        MsgBox "開いているブックはありません。"
        Exit Sub
    End If

    Dim DesktopPath As String, FilePath As String, WSH As Variant
    Set WSH = CreateObject("Wscript.Shell")
    DesktopPath = WSH.SpecialFolders("Desktop")
    FilePath = DesktopPath & "\保存名.xlsx"

    'メイン処理
    Dim i As Integer

    '開いているExcelブック数を数えて、２個目以降のブックのSheets(1)を1個目のブックに追加して閉じていく
    'ブックを閉じる場合は、最後のブックから閉じていかないとうまくいかない
    For i = xlsx.Workbooks.Count To 2 Step 1
        xlsx.Workbooks(i).Worksheets(1).Copy _
                Before:=xlsx.Workbooks(1).Sheets(1)    'ワークブック1にシートを追加してコピー
        xlsx.Workbooks(i).Close
    Next i

    xlsx.Workbooks(1).SaveAs FileName:=FilePath
    xlsx.Workbooks(1).Close

    MsgBox "完了しました。"

End Sub

生成したExcelアプリケーションは、適切なタイミングで、終了、解放しておく必要があります。
不必要になった時とか、Accessを閉じる前とか、・・・

xlsx.Quit
Set xlsx = NoThing 

「AccessVBAでExcelブックを1つにまとめて保存」プロシージャでブックを保存してますので、その最後でExcelアプリケーションを終了、解放してもいいかもです。

Comments

[NGK]

「開いているExcelブック/シートを1つにまとめて保存」の「開いている」というのは、どのように開いているのでしょうか。あるいは、開くのでしょうか。
>>>今回の処理を行う前に、別のAccessVBAコードで、いくつかのブックが開かれることになっています。そちらを対象に、「開いているExcelブック/シートを1つにまとめて保存」したいと考えています。

なので1つ以上のExcelブックは開かれている状態で、今回の処理を行いたいのですが、開いているExcelブックを認識してくれません。こちら原因分かりますでしょうか、、、？「Msgbox = ExApp.Workbooks.Count」としても、0になってしまいます。

[hatena19]

> 別のAccessVBAコードで、いくつかのブックが開かれることになっています。

どのように開いてますか。そのコードを提示してください。
また、そのコードをどこに記述してますか。標準モジュールあるいはフォームのモジュール、どちらですか。

[hatena19]

CreateObject("Excel.Application") は新規に空のエクセルアプリケーションを開きます。その場合、ブックは自動では開きません。よって、Workbooks.Count は 0 です。

[NGK]

フォームのモジュール(ボタンのクリック時イベント)で、標準モジュールに書いた以下のコードを複数回呼び出して複数のExcelブックを開いています。

Function ExcelData(frm As Form)
On Error GoTo Err_cmdExcel_Click
'DAOで抽出結果のクローンを作成
Dim xlsx As Object 'Excel.Applicationを代入するオブジェクト変数
Dim wkb As Object 'Excel.Wookbookを代入するオブジェクト変数
Dim rst As DAO.Recordset '現在のレコードセットを入れる変数
Dim idx As Long 'フィールド数変数
Dim j As Long ' 最終行取得用
Const xlUp As Integer = -4162

Set rst = Nothing 'データリストの初期化
Set rst = frm.RecordsetClone 'フォームのレコードセットのクローンを代入

'レコードが存在しない場合、処理を中止
If rst.BOF = True And rst.EOF = True Then
MsgBox "出力出来るデータがありません。", vbOKOnly + vbExclamation, "出力不可"
'レコードセットを閉じる
rst.Close: Set rst = Nothing
Exit Function
End If

'レコードが存在する場合、Excelに出力
'レコードセットの最初のデータにカーソルを移動
rst.MoveFirst

'Excelファイルを内部的に作成
Set xlsx = CreateObject("Excel.Application")
'作成されたExcelファイルにワークブックを追加
Set wkb = xlsx.Workbooks.Add()

'追加されたワークブックに、レコードセットのデータをコピー
With wkb.Worksheets(1)

For idx = 1 To rst.Fields.Count
.cells(1, idx).Value = rst.Fields(idx - 1).Name
Next

.Range("A2").CopyFromRecordset Data:=rst

'レコードセットを閉じる
rst.Close: Set rst = Nothing
'Excelデータを表示
xlsx.Visible = True
xlsx.UserControl = True
'メモリに展開されたExcel用オブジェクト変数を開放
Set wkb = Nothing
Set xlsx = Nothing

Exit_cmdExcel_Click:
Exit Function

Err_cmdExcel_Click:
MsgBox "エラーのため、Excelへ出力できません。" & vbCrLf & "一旦フォームを閉じ、再度トライしてください。" & vbCrLf & Err.Number & Err.Description, _
vbOKOnly + vbCritical, "Excel出力不可！"
Resume Exit_cmdExcel_Click
End Function

[hatena19]

このコードを回答に追記してください。回答は編集できます。

[NGK]

追記させていただきました、引き続きよろしくお願いいたします。

Answer 2

Sub hoge()

    Dim ExApp As Object
    
    On Error GoTo exception

        ' CreateObject ではすでに開いているExcelが取れないようです。
        Set ExApp = GetObject(, "Excel.Application")
    
        Dim i
        
        ' To ExApp.Workbooks(ExApp.Workbooks.Count)) は間違いです。
        For i = 1 To ExApp.Workbooks.Count
            MsgBox ExApp.Workbooks(i).Name
        Next i

exception:
    MsgBox Err.Description

End Sub

Comments

[NGK]

回答ありがとうございます。頂いたコードのように変更してみたのですが、開いているExcelブックを認識してくれません。こちら原因分かりますでしょうか、、、？「Msgbox = ExApp.Workbooks.Count」としても、0になってしまいます。

[退会済みユーザー]

Word のマクロで umau さんの回答を実行したところ、開いている Excel ファイル名が順次メッセージ表示されました。

Answer 3

これでどうでしょう。

For i = 2 To ExApp.Workbooks.Count
    'ワークブック1にシートを追加してコピー
Next

Comments

[NGK]

回答ありがとうございます。頂いたコードのように変更してみたのですが、開いているExcelブックを認識してくれません。こちら原因分かりますでしょうか、、、？「Msgbox = ExApp.Workbooks.Count」としても、0になってしまいます。

[hatena19]

CreateObject("Excel.Application") は新規に空のエクセルアプリケーションを開きます。その場合、ブックは自動では開きません。よって、Workbooks.Count は 0 です。