こんばんは。DAOでレコードセットを使ってテーブルを取得します。このテーブルのある列を見てExcelファイルを複数作りたいです。


例えばA列、C列、Z列からselectでデータを抽出してきます。A列には,1,1,1,2,2,2,2,3,3,3,3,3,5,4,9,34,34,11,11など特定の数値が入っています。これを数値別で各excelファイルに書き出して保存したいと思っています。1の塊は1.xls、2の塊は2.xlsなど自動でファイルを生成したいと思っています。selectでorder A列にして塊を作るというところまでは理解できるのですが、ここからどうやって1の塊の終わり、2の塊の終わりを判別して書き出してやるかが思いつきません。具体的に教えていただけたら幸いです。よろしくお願いいたします。

回答の条件
  • URL必須
  • 1人2回まで
  • 登録:2009/02/19 23:34:53
  • 終了:2009/02/21 19:11:04

ベストアンサー

id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692009/02/21 00:06:39

ポイント400pt

具体的なコードを作ってみました。

やっていることは、他の人の回答とそんなに違いません。

A列の値を取得して、その前に取得した値と比較して、違ったら表を整形して保存し、新たにブックを追加し、見出し行を書き込みます。A列の値が同じならばそのままデータを書き込むという動作をレコードごとに繰り返します。レコードが無くなった時点で今開いているブックを保存するという動作も必要となります。

Option Explicit

Sub Macro()
    Dim db As DAO.Database
    Dim rscset As DAO.Recordset
    Dim mySQL As String
    Dim mySource As String
    Dim i As Long
    Dim j As Integer
    Dim fc As Integer
    Dim myPath As String
    Dim strA As String
    Dim wb As Workbook
    
    'Accessのファイルのパスを指定
    mySource = ThisWorkbook.Path & "\sample.mdb"
    
    '作成されるファイルのパスを指定
    myPath = ThisWorkbook.Path
    
    'テーブルの名前を指定
    Const tableName As String = "テーブル名"
    
    '作成されるブックの開始行を指定
    Const StartRow As Long = 1
        
    Set db = DBEngine.Workspaces(0).OpenDatabase(mySource)
    
    '書き出すフィールド名を指定
    mySQL = "SELECT A列,C列,Z列 FROM " & tableName & " ORDER BY A列"
    
    Set rscset = db.OpenRecordset(mySQL)
    
    fc = rscset.Fields.Count
    
    strA = ""
    
    i = StartRow
    'レコードセットの書き出し
    While rscset.EOF = False
        If rscset.Fields("A列") <> strA Then
            If Not wb Is Nothing Then
                '表の整形
                With wb.Worksheets(1).Range(Cells(StartRow, 1), Cells(i - 1, fc))
                    .Borders(xlEdgeLeft).Weight = xlThin
                    .Borders(xlEdgeTop).Weight = xlThin
                    .Borders(xlEdgeBottom).Weight = xlThin
                    .Borders(xlEdgeRight).Weight = xlThin
                    .Borders(xlInsideVertical).Weight = xlThin
                    .Borders(xlInsideHorizontal).Weight = xlThin
                End With
                wb.SaveAs Filename:=myPath & "\" & strA & ".xls"
                wb.Close
                i = StartRow
            End If
            Set wb = Workbooks.Add
            For j = 1 To fc
                wb.Worksheets(1).Cells(i, j).Value = rscset.Fields(j - 1).Name
            Next j
            i = i + 1
            strA = rscset.Fields("A列")
        End If
        For j = 1 To fc
            Cells(i, j).Value = rscset.Fields(j - 1).Value
        Next
        i = i + 1
        rscset.MoveNext
    Wend
    
    '表の整形
    With wb.Worksheets(1).Range(Cells(StartRow, 1), Cells(i - 1, fc))
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlInsideVertical).Weight = xlThin
        .Borders(xlInsideHorizontal).Weight = xlThin
    End With
    wb.SaveAs Filename:=myPath & "\" & strA & ".xls"
    wb.Close
    
    rscset.Close
    Set rscset = Nothing
        
    db.Close
    Set db = Nothing
End Sub

http://q.hatena.ne.jp/

id:akaired

細かくコードを書いて頂きありがとうございます!嬉しいです、これを読み解き勉強したいと思います。

2009/02/21 19:10:02

その他の回答(2件)

id:sphire No.1

sphire回答回数115ベストアンサー獲得回数122009/02/20 01:00:39

ポイント27pt

言語とか不明なので適当に考えた疑似言語で。

全データ = SELECT a列,c列,z列 FROM tbl ORDER BY a;
pre = null; //preの初期値は絶対一致しない値で
foreach(行 in 全データ){
  now = 行[a列]; //a列の値
  if(now != pre){
    file = now . '.xls'; //追記するファイル名
  }
  append(file, 行);
  pre = now; //1つ前の行のa列を保持するのがミソ
}

URLはダミーです

http://hoge/

id:akaired

VBAです

2009/02/20 07:42:10
id:tap_t No.2

たっぷ回答回数45ベストアンサー獲得回数62009/02/19 23:59:21

ポイント27pt

ぱっと見では、二つの方法があります。開発環境や言語等が分からないため簡単に説明だけ書きます。

1. 数字毎のレコード数を求める SELECT 文を発行する。

対象のデータをorder A列で抽出後、数字毎のレコード数を元にしてファイルを作成する処理を行う。

2. order A列で抽出後、ループしてファイルを作成する際に、一つ前のレコードの A列の値を現在の A列の値と比較して違っていたら次のファイルとする。

こんな感じになると思います。説明だと分かり難いと思いますが、実際にコーディングしてみたら難しくはないです。

ちなみに、Excelファイルの生成は、出来ているという前提でよいのでしょうか?

http://www.hatena.ne.jp/ ダミーです。

id:akaired

VBAです。ありがとうございます。具体的にコードも教えていただけたらと思います。

2009/02/20 07:48:23
id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692009/02/21 00:06:39ここでベストアンサー

ポイント400pt

具体的なコードを作ってみました。

やっていることは、他の人の回答とそんなに違いません。

A列の値を取得して、その前に取得した値と比較して、違ったら表を整形して保存し、新たにブックを追加し、見出し行を書き込みます。A列の値が同じならばそのままデータを書き込むという動作をレコードごとに繰り返します。レコードが無くなった時点で今開いているブックを保存するという動作も必要となります。

Option Explicit

Sub Macro()
    Dim db As DAO.Database
    Dim rscset As DAO.Recordset
    Dim mySQL As String
    Dim mySource As String
    Dim i As Long
    Dim j As Integer
    Dim fc As Integer
    Dim myPath As String
    Dim strA As String
    Dim wb As Workbook
    
    'Accessのファイルのパスを指定
    mySource = ThisWorkbook.Path & "\sample.mdb"
    
    '作成されるファイルのパスを指定
    myPath = ThisWorkbook.Path
    
    'テーブルの名前を指定
    Const tableName As String = "テーブル名"
    
    '作成されるブックの開始行を指定
    Const StartRow As Long = 1
        
    Set db = DBEngine.Workspaces(0).OpenDatabase(mySource)
    
    '書き出すフィールド名を指定
    mySQL = "SELECT A列,C列,Z列 FROM " & tableName & " ORDER BY A列"
    
    Set rscset = db.OpenRecordset(mySQL)
    
    fc = rscset.Fields.Count
    
    strA = ""
    
    i = StartRow
    'レコードセットの書き出し
    While rscset.EOF = False
        If rscset.Fields("A列") <> strA Then
            If Not wb Is Nothing Then
                '表の整形
                With wb.Worksheets(1).Range(Cells(StartRow, 1), Cells(i - 1, fc))
                    .Borders(xlEdgeLeft).Weight = xlThin
                    .Borders(xlEdgeTop).Weight = xlThin
                    .Borders(xlEdgeBottom).Weight = xlThin
                    .Borders(xlEdgeRight).Weight = xlThin
                    .Borders(xlInsideVertical).Weight = xlThin
                    .Borders(xlInsideHorizontal).Weight = xlThin
                End With
                wb.SaveAs Filename:=myPath & "\" & strA & ".xls"
                wb.Close
                i = StartRow
            End If
            Set wb = Workbooks.Add
            For j = 1 To fc
                wb.Worksheets(1).Cells(i, j).Value = rscset.Fields(j - 1).Name
            Next j
            i = i + 1
            strA = rscset.Fields("A列")
        End If
        For j = 1 To fc
            Cells(i, j).Value = rscset.Fields(j - 1).Value
        Next
        i = i + 1
        rscset.MoveNext
    Wend
    
    '表の整形
    With wb.Worksheets(1).Range(Cells(StartRow, 1), Cells(i - 1, fc))
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlInsideVertical).Weight = xlThin
        .Borders(xlInsideHorizontal).Weight = xlThin
    End With
    wb.SaveAs Filename:=myPath & "\" & strA & ".xls"
    wb.Close
    
    rscset.Close
    Set rscset = Nothing
        
    db.Close
    Set db = Nothing
End Sub

http://q.hatena.ne.jp/

id:akaired

細かくコードを書いて頂きありがとうございます!嬉しいです、これを読み解き勉強したいと思います。

2009/02/21 19:10:02

コメントはまだありません

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

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

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

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