テーブルをそのままエクスポートするには？

いつもお世話になります。

Access2000＋VB.NET2003です。

今２つのテーブル（メイン、サブ）からデータアダプタ＆データセットを使用して複数の条件で絞り込んだテーブルをデータグリッドに表示させています。

この結果のテーブルをそのままエクセルへ落とすにはどうすればいいのでしょうか？

よろしくご指導お願いします。

No.1 ベストアンサー 回答者： 1050YEN 回答日時： 2006/06/05 20:40

>テーブルをそのままエクセルへ落とすには

ちょっと違いますが、データセットをエクセル落とす機能を作ってあったので、それを載せておきます。
プチ改造で、そのまま使えると思います。

　　Sub Main()
　　　　Dim l_dst As DataSet = うそんこデータセット()
　　　　Call OutputExcel(l_dst)
　　End Sub

#Region "出力関係"

#Region "出力"
　　Public Sub OutputExcel(ByVal p_dst As DataSet)
　　　　If (p_dst Is Nothing) OrElse (p_dst.Tables.Count = 0) Then
　　　　　　Return
　　　　End If

　　　　'//Dim l_xlsBook As Excel.Workbook = GetBook()　//参照設定用
　　　　Dim l_xlsBook As Object = GetBook()

　　　　'テーブル数がシート数より多い場合
　　　　If (l_xlsBook.Worksheets.Count < p_dst.Tables.Count) Then
　　　　　　'不足分のシートをブック末に追加する
　　　　　　l_xlsBook.Worksheets.Add(, l_xlsBook.Worksheets(l_xlsBook.Worksheets.Count), p_dst.Tables.Count - l_xlsBook.Worksheets.Count)
　　　　End If
　　　　'先頭のシートを選択する
　　　　l_xlsBook.Worksheets(1).Select()

　　　　Dim i As Integer
　　　　For i = 1 To p_dst.Tables.Count
　　　　　　'出力メイン処理を行う
　　　　　　Call OutputExcelExec(p_dst.Tables(i - 1), l_xlsBook.Worksheets(i), 1, 1)
　　　　Next

　　End Sub
#End Region

#Region "出力実行部"
　　'//Private Sub OutputExcelExec(ByVal p_dtb As DataTable, ByVal p_xlsSheet As Excel.Worksheet, ByVal p_intRow As Integer, ByVal p_intCol As Integer) //参照設定用
　　Private Sub OutputExcelExec(ByVal p_dtb As DataTable, ByVal p_xlsSheet As Object, ByVal p_intRow As Integer, ByVal p_intCol As Integer)
　　　　Dim l_objValues As Object
　　　　Dim l_drw As DataRow
　　　　'//Dim l_objRange As Excel.Range　　//参照設定用
　　　　Dim l_objRange As Object
　　　　Dim l_intCountRows As Integer = p_dtb.Rows.Count
　　　　Dim l_intCountCols As Integer = p_dtb.Columns.Count
　　　　Dim i, j As Integer

　　　　'シート名を変更する場合
　　　　p_xlsSheet.Name = p_dtb.TableName

　　　　'領域確保(ROW:ヘッダ分の1件+データ件数/COL:カラム数)
　　　　ReDim l_objValues(l_intCountRows, l_intCountCols - 1)

　　　　'ヘッダ情報
　　　　For i = 0 To p_dtb.Columns.Count - 1
　　　　　　l_objValues(0, i) = p_dtb.Columns(i).ColumnName
　　　　Next

　　　　'データ情報
　　　　For i = 0 To p_dtb.Rows.Count - 1
　　　　　　l_drw = p_dtb.Rows(i)
　　　　　　For j = 0 To p_dtb.Columns.Count - 1
　　　　　　　　l_objValues(i + 1, j) = l_drw.Item(j).ToString
　　　　　　Next
　　　　Next

　　　　'データ貼り付け範囲を設定
　　　　With p_xlsSheet
　　　　　　l_objRange = .Range(.Cells(1), .Cells(l_intCountRows + 1, l_intCountCols))
　　　　End With
　　　　'データ貼り付け範囲を補正
　　　　l_objRange = l_objRange.Offset(p_intRow - 1, p_intCol - 1)

　　　　'貼り付け範囲の書式を文字列にする場合(頭ゼロの入ったコード対応)
　　　　l_objRange.NumberFormatLocal = "@"

　　　　'貼り付け
　　　　l_objRange.Value = l_objValues
　　End Sub
#End Region

#End Region

#Region " エクセル操作"
　　'エクセルブックを新規作成し返却をする
　　'//Private Function GetBook() As Excel.Workbook //参照設定用
　　Private Function GetBook() As Object
　　　　'//Dim l_xlsApp As Excel.Application = GetExcel()　 //参照設定用
　　　　Dim l_xlsApp As Object = GetExcel()
　　　　Return l_xlsApp.Workbooks.Add
　　End Function
　　'エクセルインスタンスを取得する/存在しなければ
　　'//Private Function GetExcel() As Excel.Application //参照設定用
　　Private Function GetExcel() As Object
　　　　'//Dim l_xlsApp As Excel.Application　　//参照設定用
　　　　Dim l_xlsApp As Object
　　　　On Error Resume Next
　　　　l_xlsApp = GetObject(, "Excel.Application")
　　　　If l_xlsApp Is Nothing Then
　　　　　　l_xlsApp = CreateObject("Excel.Application")
　　　　　　l_xlsApp.Visible = True
　　　　End If
　　　　Return l_xlsApp
　　End Function
#End Region

#Region " うそんこしりーず"
　　Function うそんこデータセット() As DataSet
　　　　Dim l_dst As New DataSet()
　　　　l_dst.Merge(うそんこテーブル("大文字1", "A", "Z"))
　　　　l_dst.Merge(うそんこテーブル("小文字2", "a", "z"))
　　　　l_dst.Merge(うそんこテーブル("カナ1", Chr(177), Chr(186)))
　　　　l_dst.Merge(うそんこテーブル("カナ2", Chr(187), Chr(201)))
　　　　Return l_dst
　　End Function
　　Function うそんこテーブル(ByVal p_TblName As String, ByVal p_chr1 As String, ByVal p_chr2 As String) As DataTable
　　　　Dim i As Integer

　　　　Dim l_dtb As New DataTable(p_TblName)
　　　　l_dtb.Columns.Add(New DataColumn("コード", GetType(String)))
　　　　l_dtb.Columns.Add(New DataColumn("文字", GetType(String)))

　　　　For i = Asc(p_chr1) To Asc(p_chr2)
　　　　　　l_dtb.Rows.Add(New Object() {i.ToString("00000"), Chr(i)})
　　　　Next
　　　　Return l_dtb
　　End Function
#End Region

この回答へのお礼

ご丁寧な回答ありがとうございます。
よく読んで頑張ってみます。
（実際にやりたかったこととほんとに近いので助かります）
ありがとうございました。

お礼日時：2006/06/06 13:00