文書番号: 401981
最終更新日: 2004/04/27
'関数名:ExportToExcel ' '引数: ' FileName --> 既存の Excel 5.0 のファイル名をフルパスで指定 ' RecName --> テーブル、クエリー名 (Excel 側の行数制限により、16,383 レコー ド以下とします。) ' SheetNum --> ワークシート名 '設定例: 'Function ExportToExcel("c:\book1.xls","テーブル 1","Sheet3") ' '用途: ' RecName で指定されたテーブルかクエリーのレコードセットを FileName ファイルの ' SheetNum シートに表示し、保存します。RecName のレコードが 0 件のときは処理を ' 中止します。 ' Function ExportToExcel (FileName As Variant, RecName As Variant, SheetNum As Variant) Dim MyDB As Database Dim xlsheet As Object Dim MyRecSet As Recordset Dim MyField As Field Dim FC As Long Dim RC As Long On Error GoTo ErrorHandler ' 'Excel のファイルが存在するか確認します ' If Dir(FileName) = "" Then MsgBox "ファイル " & FileName & " は見つかりません。" Exit Function End If Set MyDB = DBEngine(0)(0) Set MyRecSet = MyDB.OpenRecordset(RecName) ' 'レコード数が存在するか確認します ' If MyRecSet.EOF = True Then MsgBox RecName & " にはレコードが 1 件もありません。処理を中止します。" Exit Function End If ' 'MyRecSet のフィールド数を取得して、FC に代入します ' FC = MyRecSet.Fields.Count ' 'MyRecSet の RecordCount プロパティを参照するために最後のレコードに '移動します ' MyRecSet.MoveLast ' 'MyRecSet のレコード数を、RC に代入します ' RC = MyRecSet.RecordCount ' '指定された Excel ファイルを xlsheet に代入します ' Set xlsheet = GetObject(FileName, "excel.sheet.5") xlsheet.application.Windows(1).Visible = True xlsheet.application.Activeworkbook.Sheets(SheetNum).select ' 'フィールド名をワークシートに表示します ' For ColNum = 1 To FC xlsheet.application.goto "r1" & "c" & ColNum xlsheet.application.Activecell.value = MyRecSet.Fields(ColNum - 1).Name Next ColNum ' 'データをワークシートに書き出します。 ' MyRecSet.MoveFirst For RowNum = 2 To RC + 1 For ColNum = 1 To FC xlsheet.application.goto "r" & RowNum & "c" & ColNum xlsheet.application.Activecell.value = MyRecSet.Fields(ColNum - 1).value Next ColNum MyRecSet.MoveNext Next RowNum ' 'Excel のワークシートを保存します ' xlsheet.application.Activeworkbook.Save ' 'Excel を終了します ' xlsheet.application.[Quit] ' 'オブジェクト変数を初期化します ' Set xlsheet = Nothing MyRecSet.Close MsgBox RC & "件のレコードがエクスポートされました。" Exit Function ErrorHandler: MsgBox "エラーが発生しました。引き数に間違いがないか確認してください。" & Chr$(13) & Chr$(10) → (前行の続き) & "また、Excel 側のファイルの設定も確認してください。" Exit Function End Function
?ExportToExcel("C:\BOOK1.XLS","テーブル 1","Sheet3")
Keywords: KBINFO KB401981
Technology: kbAccessSearch kbExcel500 kbExcelSearch kbExcelWinSearch