| |
▼hm_Yh さん：
こんにちは。
>こんな難題を解けるって、難しいです。
まずはテーブル全部を Excelファイル にエクスポート、
それができたら No 毎に それぞれ Excelファイル へエクスポート、
それができたら No 毎に 同じExcelファイル へエクスポート、
…
の様に少しずつスキルアップしていく事が
御自身でコードを組めるようになる近道かと思われます。
>早速、変更しました。
今回は SEQ というフィールド名としてコードを組んでみました。
Sub Excelへエクスポート()
'※要参照 Microsoft DAO x.x Object Library
Const TName = "テーブルA" 'データの入っているテーブル名
Const OutFile = "C:\Export.xls" 'エクスポート先 Excelファイル名
Dim RS1 As DAO.Recordset
Dim RS2 As DAO.Recordset
Dim strSQL1 As String
Dim strSQL2 As String
Dim xlsApp As Object
Dim xlsWkb As Object
Dim xlsSht As Object
Dim i As Long
On Error Resume Next
Kill OutFile
On Error GoTo 0
Set xlsApp = CreateObject("Excel.Application")
Set xlsWkb = xlsApp.Workbooks.Add
strSQL2 = "SELECT DISTINCT SEQ FROM " & TName
Set RS2 = CurrentDb.OpenRecordset(strSQL2, dbOpenSnapshot)
Do Until RS2.EOF
Set xlsSht = xlsWkb.Worksheets.Add
xlsSht.Name = RS2![SEQ]
strSQL1 = "SELECT * FROM " & TName _
& " WHERE SEQ = '" & RS2![SEQ] & "';"
Set RS1 = CurrentDb.OpenRecordset(strSQL1, dbOpenSnapshot)
For i = 1 To RS1.Fields.Count
xlsSht.Cells(1, i).Value = RS1(i - 1).Name
Next
xlsSht.Range("A2").CopyFromRecordset RS1
xlsSht.Range("A1").CurrentRegion.Columns.AutoFit
xlsSht.Range("A1").CurrentRegion.Rows.AutoFit
RS1.Close
Set RS1 = Nothing
RS2.MoveNext
Loop
Set RS1 = Nothing
RS2.Close: Set RS2 = Nothing
On Error Resume Next
For i = 1 To 3
xlsWkb.Sheets("Sheet" & i).Delete
Next
On Error GoTo 0
Set xlsSht = Nothing
xlsWkb.SaveAs OutFile
xlsWkb.Close: Set xlsWkb = Nothing
xlsApp.Quit: Set xlsApp = Nothing
MsgBox "出力が終了しました。"
End Sub
コードで解らない箇所がありましたら
再度質問して頂ければ当方の解る範囲でしたらお答えできるかと思われます。
|
|
![[未読]](./data/access/image/read_icon.gif){kind=icon}
