http://q.hatena.ne.jp/1235054091の続きの質問です。

レコードセットを最初に作ります。
sql="select distinct ID * from table order by ID"
rs=openrecordset(sql)
これでrsを作りました。

続いてループでまわします。そして別のレコードセットを作ります。
Do until rs.eof
sqlnext="select * from table where ID=" & rs!ID
set rs2=nothing
rs2.openrecordset(sqlnext)

Do until rs2.eof

Excelに書き込み作業
 rs2.movenext
loop

excelに保存作業
rs.movenext
loop

という回りくどいやり方でexcelへ保存作業を行っております。例えばIDが1,1,2,2,2,3,3,3とあった場合、1は1の塊で出力、2は2の塊で出力、3は3の塊で出力して保存したいと思っています。この例だと3ファイルできるはずです。3ファイルは作ることができました。しかし、1のファイルを見ると、1のIDだけをひっぱってきているので問題ない。2のファイルを見るとIDが1と2のファイルを持ってきている、×。3つ目のファイル。IDが1,2、3のIDを引っ張ってきている。ダメ。という具合に上手に塊で出力することができません。どこが悪いのでしょうか?

回答の条件
  • URL必須
  • 1人5回まで
  • 登録:2009/02/21 21:02:26
  • 終了:2009/02/23 01:27:19

ベストアンサー

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912009/02/21 22:19:05

ポイント400pt

コードの全体が見えていないので何とも言えませんが、クエリの処理よりEXCELのデータ出力処理の

部分の問題であるような気がします。


下記は同様の処理をファイル別に出力した例ですが、こちらの試験の範囲ではデータの重複なく出力

できました。


実際の EXCEL への出力の部分を提示いただければ具体的な回答ができるかと思います。

Option Explicit

Sub dataDistributer()
    Dim wb As Workbook
    'テーブルの名前を指定
    Const tableName As String = "テーブル1"
    
    Dim res1 As DAO.Recordset
    Dim res2 As DAO.Recordset
    
    Set res1 = query("SELECT DISTINCT ID FROM " & tableName & " ORDER BY ID")

    Dim r As Long, c As Long
    Do While res1.EOF = False
        Set res2 = query("SELECT * FROM " & tableName & " WHERE ID = " & res1.Fields(0).Value)
        Set wb = Workbooks.Add()
        r = 0
        Do While res2.EOF = False
            r = r + 1
            For c = 0 To res2.Fields.Count - 1
                wb.Worksheets(1).Cells(r, c + 1).Value = res2.Fields(c).Value
            Next
            res2.MoveNext
        Loop
        wb.SaveAs ThisWorkbook.Path & "\" & res1.Fields(0).Value & ".xls"
        res1.MoveNext
    Loop
End Sub


Function query(sql As String) As DAO.Recordset
    'Accessのファイルのパスを指定
    Const mySource = "C:\Database\myDB.mdb"
    Dim db As DAO.Database
    Set db = DBEngine.Workspaces(0).OpenDatabase(mySource)
    Set query = db.OpenRecordset(sql)
    Set db = Nothing
End Function

http://www.happy2-island.com/access/gogo03/capter00207.shtml

id:akaired

ご回答ありがとうございます。excelへの書き込み作業の部分は、

Cells(row, col).Value = rs2!ID

Cells(row, col).Value = rs2!NAME

Dim x as string

x=rs2!ID

.....

とレコードセット2の値をcells関数で指定して保存しています。

続きまして、rs.movenextでrs2のレコードセットが空になったら、Pathで出力先フォルダを決めて、

filename=Path & x

wb.saveas filename

これで保存します。そして、

rs.movenextで最初の行に戻ります。具体性に欠けるかも知れませんが、よろしくお願いいたします。

2009/02/21 23:39:53

その他の回答(1件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912009/02/21 22:19:05ここでベストアンサー

ポイント400pt

コードの全体が見えていないので何とも言えませんが、クエリの処理よりEXCELのデータ出力処理の

部分の問題であるような気がします。


下記は同様の処理をファイル別に出力した例ですが、こちらの試験の範囲ではデータの重複なく出力

できました。


実際の EXCEL への出力の部分を提示いただければ具体的な回答ができるかと思います。

Option Explicit

Sub dataDistributer()
    Dim wb As Workbook
    'テーブルの名前を指定
    Const tableName As String = "テーブル1"
    
    Dim res1 As DAO.Recordset
    Dim res2 As DAO.Recordset
    
    Set res1 = query("SELECT DISTINCT ID FROM " & tableName & " ORDER BY ID")

    Dim r As Long, c As Long
    Do While res1.EOF = False
        Set res2 = query("SELECT * FROM " & tableName & " WHERE ID = " & res1.Fields(0).Value)
        Set wb = Workbooks.Add()
        r = 0
        Do While res2.EOF = False
            r = r + 1
            For c = 0 To res2.Fields.Count - 1
                wb.Worksheets(1).Cells(r, c + 1).Value = res2.Fields(c).Value
            Next
            res2.MoveNext
        Loop
        wb.SaveAs ThisWorkbook.Path & "\" & res1.Fields(0).Value & ".xls"
        res1.MoveNext
    Loop
End Sub


Function query(sql As String) As DAO.Recordset
    'Accessのファイルのパスを指定
    Const mySource = "C:\Database\myDB.mdb"
    Dim db As DAO.Database
    Set db = DBEngine.Workspaces(0).OpenDatabase(mySource)
    Set query = db.OpenRecordset(sql)
    Set db = Nothing
End Function

http://www.happy2-island.com/access/gogo03/capter00207.shtml

id:akaired

ご回答ありがとうございます。excelへの書き込み作業の部分は、

Cells(row, col).Value = rs2!ID

Cells(row, col).Value = rs2!NAME

Dim x as string

x=rs2!ID

.....

とレコードセット2の値をcells関数で指定して保存しています。

続きまして、rs.movenextでrs2のレコードセットが空になったら、Pathで出力先フォルダを決めて、

filename=Path & x

wb.saveas filename

これで保存します。そして、

rs.movenextで最初の行に戻ります。具体性に欠けるかも知れませんが、よろしくお願いいたします。

2009/02/21 23:39:53
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912009/02/22 00:13:05

先の回答で言い忘れましたが、コメントを有効にしていただけると対応がしやすいです。


肝心な部分が書かれていないので何とも言えませんが、ファイルの扱いはどのようになっているでしょうか。

    Do While rs1.EOF = False
        Set rs2 = ・・・・・
        '★★★★ここに wb を新規で作成する(もしくは初期化する)処理が必要
        Do While rs2.EOF = False
              セルの書き込み処理
            row = row+1
        Loop
        filename=Path & x
        wb.saveas filename
    Loop

のような構造だと、追記して上書き処理なので質問された現象になるかと思います。


これにファイルの作成処理は先の回答で行っているのでご参考ください。

        Set wb = Workbooks.Add()

の部分です。

http://officetanaka.net/excel/vba/file/index.htm

id:akaired

わかりにくくて申し訳ありません。下記に再度書いてみました。

テーブルはanimalでフィールド名にID、カテゴリ、種類とあります。ID=1,1,2,2,3... カテゴリ犬、犬、猫、猫、鳥... 種類=マルチーズ、秋田犬、ペルシャ猫、雑種猫、フクロウ

というデータがあります。

Dim rs1 as dao.recordset, Dim rs2 as dao.recordset Dim st1 as string,Dim st2 as string dim row as int=0 Dim output as string Dim path as string

Set apx = CreateObject("Excel.Application")

Set wb = xl.Workbooks.Add

Set ws = x.Worksheets(1)

st1="select distinct ID from animal order by animal"

set rs1=openrecordset(st1,dbopendynaset)

Do until rs1.eof

st2="select ID,カテゴリ、種類 where ID='" & rs1!ID & "'"

set rs2=nothing rs2=openrecordset(st2,dbopendynaset)

Do until rs2.eof

row =row+1

cells(row,1).value=rs2!ID

cells(row,2).value=rs2!カテゴリ

cells(row,3).value=rs2!種類

dim x as string x=rs2!ID

rs2.movenext

loop

path="C:\"

output = path & x & "xls"

web.saveas output

rs1.movenext

loop

msgbox "end"

といった感じになります。

2009/02/22 09:40:22
  • id:Mook
    最初からコードを提示いただいた方が、解決が早かったですね。
    ただ、このコードは説明用に書かれたもので、実際に使用されている
    コードではないようですね。

    サンプルとしても VBE で書かれた方がよいかと思います。
    (少なくとも文法的な誤記は排除できますので)


    原因は先に回答したように、
      Set wb = xl.Workbooks.Add
      Set ws = x.Worksheets(1)
    がループの外にあることです。この部分を
      Do until rs1.eof
    の後ろに移動してください。

    実際は、
      Set wb = apx.Workbooks.Add
      Set ws = wb.Worksheets(1)
    でしょうか。

    確認なのですが、これは Access で実行しているのでしょうか。
    また、お使いの OS とOffice のバージョンは何でしょうか。
    今後の参考に伺えればと思います。
  • id:akaired
    ご回答ありがとうございます。OSはXP Pro、ACCESSは2002です。教えて頂いた通りやりましたら無事にできました。感謝です!

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません