ACCESS2003VBAの質問です。

下記の様なレコードを持つテーブル1があります。

テーブル1

日付   内容

7月1日  Aが12箱、Bが6箱、Cが7箱、Dが7箱
7月2日  Eが5箱、Bが7箱
7月3日  Dが3箱

このテーブルから

テーブル2

日付   種別  箱数

7月1日  A    12
7月1日  B    6
7月1日  C    7
7月1日  D    7
7月2日  E    5
7月2日  B    7
7月3日  D    3

のようなテーブルを作成したいです。
VBAでの処理方法を教えてください。

回答の条件
  • 1人5回まで
  • 登録:2009/07/30 19:50:20
  • 終了:2009/08/06 19:55:02

回答(2件)

id:jccrh1 No.1

jccrh1回答回数111ベストアンサー獲得回数192009/07/30 21:30:01

ポイント35pt

一応、下記の処理でできると思います。

Sub 内容分割処理()
  Dim daoDB  As Database
  Dim daoRS1 As Recordset
  Dim daoRS2 As Recordset
  Dim I      As Integer
  Dim 箱分割  As Variant
  Dim が分割  As Variant
  
  Set daoDB = CurrentDb
  Set daoRS1 = daoDB.OpenRecordset("テーブル1", dbOpenTable)
  Set daoRS2 = daoDB.OpenRecordset("テーブル2", dbOpenTable)
  Do While (Not (daoRS1.EOF))
   箱分割 = Split(daoRS1!内容, "箱、")
   For I = 0 To UBound(箱分割)
     が分割 = Split(箱分割(I), "が")
     daoRS2.AddNew
     daoRS2!日付 = daoRS1!日付
      daoRS2!種別 = が分割(0)
     daoRS2!箱数 = Val(が分割(1))
     daoRS2.Update
    Next I
    daoRS1.MoveNext
  Loop
  daoRS1.Close
  daoRS2.Close
  daoDB.Close
End Sub
id:rupopon

ありがとうございます。やってみます。

2009/07/31 09:17:33
id:kn1967 No.2

kn1967回答回数2915ベストアンサー獲得回数3012009/07/30 21:44:08

ポイント35pt
Private Sub コマンド0_Click()
    '準備
    Dim db As DAO.Database
    Dim rs1, rs2 As DAO.Recordset
    Dim a1() As String, a2() As String
    Dim c As Integer, i As Integer
    
    '接続
    Set db = CurrentDb
    Set rs1 = db.OpenRecordset("テーブル1")
    Set rs2 = db.OpenRecordset("テーブル2")
    
    '変換処理
    rs1.MoveFirst: '初期位置確定(オープン時の位置は不確定のため)
    Do Until rs1.EOF
        a1() = Split(rs1.内容, "、", , vbTextCompare):' vbTextCompareを忘れると変なところで切れるかも
        c = UBound(a1): 'for内で何度も数えるのは効率悪いので先に数えておく
        For i = 0 To c
           a2() = Split(a1(i), "が", , vbTextCompare)
           rs2.AddNew: '新規レコード追加
           rs2!日付 = rs1.日付
           rs2!種別 = a2(0)
           rs2!箱数 = Val(a2(1)): 'valは数字の後に続く文字列は無視してくれるので便利。
           rs2.Update: '新規レコードへの書き込み
        Next i
        rs1.MoveNext
    Loop
    
    '開放
    rs2.Close
    Set rs2 = Nothing
    rs1.Close
    Set rs1 = Nothing
    db.Close
    Set bd = Nothing
End Sub

※テーブル2には無条件で追記していきますので、

 このコードを走らせる前に、あらかじめ空っぽにしておく必要があります。

※「無条件で追記」ではなく「既存であれば追記せず更新する」に変更したい場合は、

 いきなりaddnewではなくfind失敗(無かった場合) の時だけaddnewするように変更します。

id:rupopon

ありがとうございます。やってみます。

2009/07/31 09:23:54

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

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

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

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