Accessで縦と横を入れ替えたい

りんご みかん ぶどう バナナ いちご
佐藤 2 　 1 　　 1 　 1 　1
鈴木 1 　　　　 1 　 1
田中 1 　 2 　　　　　 1


上記のようなテーブルがあるのですが、これを下記のようにしたいです。

担当者 種別
田中 りんご
鈴木 りんご
佐藤 りんご
田中 みかん
佐藤 みかん
佐藤 ぶどう
鈴木 バナナ
佐藤 バナナ
田中 いちご
鈴木 いちご
佐藤 いちご
佐藤 りんご
田中 みかん

種別の隣に数量がきてもOKです。
ご教授お願い致します。

No.11 回答者： piroin654 回答日時： 2015/01/12 14:15

担当者 種別

佐藤　りんご　2
鈴木　りんご　1
田中　りんご　1
佐藤　みかん　1
田中　みかん　2
佐藤　ぶどう　1
鈴木　ぶどう　1
佐藤　バナナ　1
鈴木　バナナ　1
…

といった感じにできれば。


の、....　以下がどのようになっているのかが
問題なのですが・・・・。
質問のデータでは「鈴木」には「ぶどう」は無かったような・・・。

（１）
ともあれ、以下では


　　Dim db As DAO.Database
　　Dim rs1 As DAO.Recordset
　　Dim rs2 As DAO.Recordset
　　Dim j As Long
　　Dim k As Long

　　Set db = CurrentDb
　　Set rs1 = db.OpenRecordset("テーブルA")
　　Set rs2 = db.OpenRecordset("テーブルB", dbOpenDynaset)


　　　　For k = 1 To rs1.Fields.Count - 1
　　　　　　rs1.MoveFirst
　　　　　　Do Until rs1.EOF
　　　　　　　　If Not IsNull(rs1.Fields(k)) Then
　　　　　　　　　　rs2.AddNew
　　　　　　　　　　rs2!担当者 = rs1!名前
　　　　　　　　　　rs2!種別 = rs1.Fields(k).Name
　　　　　　　　　　rs2!数量 = rs1.Fields(k).Value
　　　　　　　　　　rs2.Update
　　　　　　　　End If
　　　　　　　　rs1.MoveNext
　　　　　　Loop
　　　　Next k


　　rs1.Close: Set rs1 = Nothing
　　rs2.Close: Set rs2 = Nothing
　　db.Close: Set db = Nothing


データは、

ID　　担当者　　種別　　数量
1　　　佐藤　　　りんご　2
2　　　鈴木　　　りんご　1
3　　　田中　　　りんご　1
4　　　佐藤　　　みかん　1
5　　　田中　　　みかん　2
6　　　佐藤　　　ぶどう　1
7　　　佐藤　　　バナナ　1
8　　　鈴木　　　バナナ　1
9　　　佐藤　　　いちご　1
10　　　鈴木　　いちご　　1
11　　　田中　　いちご　　1

のように、単純に「テーブルA」の先頭レコードから
データを取り出し、「テーブルB」に格納します。
なお、「テーブルA」でデータがNullのものも表示するならば、
　　　rs2!数量 = rs1.Fields(k).Value
を、
　　　rs2!数量 = Nz(rs1.Fields(k).Value)
Nullを0とするならば、
　　　rs2!数量 = Nz(rs1.Fields(k).Value, 0)
とします。


（２）
以下では、

　　Dim db As DAO.Database
　　Dim rs1 As DAO.Recordset
　　Dim rs2 As DAO.Recordset
　　Dim i As Long
　　Dim iMax As Long
　　Dim j As Long
　　Dim k As Long

　　Set db = CurrentDb
　　Set rs1 = db.OpenRecordset("テーブルA")
　　Set rs2 = db.OpenRecordset("テーブルB", dbOpenDynaset)

　　iMax = 1
　　rs1.MoveFirst
　　Do Until rs1.EOF
　　　　For i = 1 To rs1.Fields.Count - 1
　　　　　　If Not IsNull(rs1.Fields(i)) Then
　　　　　　　　If rs1.Fields(i).Value > iMax Then
　　　　　　　　　　iMax = rs1.Fields(i).Value
　　　　　　　　End If
　　　　　　End If
　　　　Next i
　　　　rs1.MoveNext
　　Loop

　　For j = 1 To iMax
　　　　For k = 1 To rs1.Fields.Count - 1
　　　　　　rs1.MoveFirst
　　　　　　Do Until rs1.EOF
　　　　　　　　If Not IsNull(rs1.Fields(k)) Then
　　　　　　　　　　If rs1.Fields(k).Value >= j Then
　　　　　　　　　　　　rs2.AddNew
　　　　　　　　　　　　rs2!担当者 = rs1!名前
　　　　　　　　　　　　rs2!種別 = rs1.Fields(k).Name
　　　　　　　　　　　　rs2!数量 = rs1.Fields(k).Value
　　　　　　　　　　　　rs2.Update
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　　　rs1.MoveNext
　　　　　　Loop
　　　　Next k
　　Next j

　　rs1.Close: Set rs1 = Nothing
　　rs2.Close: Set rs2 = Nothing
　　db.Close: Set db = Nothing


取り出したデータは、

ID　　担当者　　種別　　数量
1　　　佐藤　　　りんご　2
2　　　鈴木　　　りんご　1
3　　　田中　　　りんご　1
4　　　佐藤　　　みかん　1
5　　　田中　　　みかん　2
6　　　佐藤　　　ぶどう　1
7　　　佐藤　　　バナナ　1
8　　　鈴木　　　バナナ　1
9　　　佐藤　　　いちご　1
10　　　鈴木　　いちご　1
11　　　田中　　いちご　1
12　　　佐藤　　りんご　2
13　　　田中　　みかん　2

のように、「テーブルB」に格納されます。
Nullのデータの処理については(1)と同じです。


(1)と(2)のどちらのデータの並びが必要なのかを
もう少し・・・。

以上です。たぶん動くと思いますが。

No.12 回答者： piroin654 回答日時： 2015/01/12 14:32

失礼しました。

訂正です。
No11の(2)の終わりに、

Nullのデータの処理については(1)と同じです。

としていますが、処理には多少コードを
変更しなければならないので、必要ならば
提示しますが。

この回答へのお礼

何度も申し訳ありません。
元々のデータが

佐藤…りんご2、みかん1、ぶどう1、バナナ1、いちご1
鈴木…りんご1、バナナ1、いちご1
田中…りんご1、みかん2、いちご1　
となっているテーブルを

ID　　担当者　　種別　　数量
1　　　佐藤　　　りんご　2
2　　　鈴木　　　りんご　1
3　　　田中　　　りんご　1
4　　　佐藤　　　みかん　1
5　　　田中　　　みかん　2
6　　　佐藤　　　ぶどう　1
7　　　佐藤　　　バナナ　1
8　　　鈴木　　　バナナ　1
9　　　佐藤　　　いちご　1
10　　　鈴木　　いちご　　1
11　　　田中　　いちご　　1

のようにできればOKなので、(1)のほうでしょうか。

お礼日時：2015/01/12 16:31

No.13 回答者： piroin654 回答日時： 2015/01/12 16:53

>のようにできればOKなので、(1)のほうでしょうか。

はい。(1)です。できましたか？

この回答へのお礼

コードの実行はできましたが、数量がゼロのところを表示しないようにはできないでしょうか？

お礼日時：2015/01/12 17:36

No.14 回答者： piroin654 回答日時： 2015/01/12 18:12

＞数量がゼロのところを表示しないようにはできないでしょうか？

(1)
それでは、Nullの場合も0の場合もはじく、ということならば、

　　Dim db As DAO.Database
　　Dim rs1 As DAO.Recordset
　　Dim rs2 As DAO.Recordset
　　Dim j As Long
　　Dim k As Long

　　Set db = CurrentDb
　　Set rs1 = db.OpenRecordset("テーブルA")
　　Set rs2 = db.OpenRecordset("テーブルB", dbOpenDynaset)


　　　　For k = 1 To rs1.Fields.Count - 1
　　　　　　rs1.MoveFirst
　　　　　　Do Until rs1.EOF
　　　　　　　　If Not IsNull(rs1.Fields(k)) Then
　　　　　　　　　　If Not rs1.Fields(k).Value = 0 Then
　　　　　　　　　　　　rs2.AddNew
　　　　　　　　　　　　rs2!担当者 = rs1!名前
　　　　　　　　　　　　rs2!種別 = rs1.Fields(k).Name
　　　　　　　　　　　　rs2!数量 = rs1.Fields(k).Value
　　　　　　　　　　　　rs2.Update
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　　　rs1.MoveNext
　　　　　　Loop
　　　　Next k


　　rs1.Close: Set rs1 = Nothing
　　rs2.Close: Set rs2 = Nothing
　　db.Close: Set db = Nothing



(2)
テーブルのデータにはNullがないので、0の場合を
はじく、というのであれば、

　　Dim db As DAO.Database
　　Dim rs1 As DAO.Recordset
　　Dim rs2 As DAO.Recordset
　　Dim j As Long
　　Dim k As Long

　　Set db = CurrentDb
　　Set rs1 = db.OpenRecordset("テーブルA")
　　Set rs2 = db.OpenRecordset("テーブルB", dbOpenDynaset)


　　　　For k = 1 To rs1.Fields.Count - 1
　　　　　　rs1.MoveFirst
　　　　　　Do Until rs1.EOF
　　　　　　　　　　If Not rs1.Fields(k).Value = 0 Then
　　　　　　　　　　　　rs2.AddNew
　　　　　　　　　　　　rs2!担当者 = rs1!名前
　　　　　　　　　　　　rs2!種別 = rs1.Fields(k).Name
　　　　　　　　　　　　rs2!数量 = rs1.Fields(k).Value
　　　　　　　　　　　　rs2.Update
　　　　　　　　　　End If
　　　　　　　　rs1.MoveNext
　　　　　　Loop
　　　　Next k


　　rs1.Close: Set rs1 = Nothing
　　rs2.Close: Set rs2 = Nothing
　　db.Close: Set db = Nothing


要するに、

　　　　　　　　If Not IsNull(rs1.Fields(k)) Then
　　　　　　　　　　If Not rs1.Fields(k).Value = 0 Then

の条件式を両方入れるか一方にするかの違いです。

この回答へのお礼

できました。
いろいろとお世話になりました。ありがとうございました。

お礼日時：2015/01/12 19:23

No.15 回答者： f_a_007 回答日時： 2015/01/12 21:37

【続】DXSelect()

DXSelect()の戻り値は添付図のようです。この戻り値をSplit関数で配列 strRecord()に格納。その後、For-Next でテーブルに挿入。

strSQL = "INSERT INTO テーブル3 (ID, 担当者, 種別, 数量) VALUES (XXXXX)"
N=UBound(strRecord)
For I = 0 To N
　　DoCmd.RunSQL Replace(strRecord(I), XXXXX, strRecord(I))
Next I

DBSelect関数では敢えて数量0を除外していません。もし、仮にそういう希望であれば、最後に

DoCmd.RunSQL "DELETE FROM ・・・・"

の１行を。

Public Function DXSelect(ByVal strQuerySQL As String, _
　　　　　　　　　　　　 Optional strPause As String = ";") As String
On Error GoTo Err_DXSelect
　　Dim isTopField　As Boolean
　　Dim I　　　　　 As Integer
　　Dim J　　　　　 As Integer
　　Dim N　　　　　 As Integer
　　Dim rst　　　　 As ADODB.Recordset
　　Dim fld　　　　 As ADODB.Field
　　Dim strTanto　　As String
　　Dim strList　　 As String
　　Dim strNewList　As String
　　
　　Set rst = New ADODB.Recordset
　　With rst
　　　　.Open strQuerySQL, _
　　　　　　　CurrentProject.Connection, _
　　　　　　　adOpenStatic, _
　　　　　　　adLockReadOnly
　　　　If Not .BOF Then
　　　　　　J = 0
　　　　　　N = .RecordCount - 1
　　　　　　.MoveFirst
　　　　　　For I = 0 To N
　　　　　　　　isTopField = True
　　　　　　　　For Each fld In .Fields
　　　　　　　　　　If isTopField Then
　　　　　　　　　　　　strTanto = "'" & fld.Value & "'"
　　　　　　　　　　　　isTopField = False
　　　　　　　　　　Else
　　　　　　　　　　　　strList = strList & J & "," & _
　　　　　　　　　　　　　　　　　strTanto & "," & _
　　　　　　　　　　　　　　　　　"'" & fld.Name & "'" & "," & _
　　　　　　　　　　　　　　　　　fld.Value & Chr(13)
　　　　　　　　　　End If
　　　　　　　　　　J = J + 1
　　　　　　　　Next fld
　　　　　　　　.MoveNext
　　　　　　Next I
　　　　Else
　　　　　　strList = ""
　　　　End If
　　End With
Exit_DXSelect:
On Error Resume Next
　　rst.Close
　　Set rst = Nothing
　　DXSelect = IIf(Len(strList) > 0, Replace(strList & "[END]", Chr(13) & "[END]", ""), "")
　　Exit Function
Err_DXSelect:
　　MsgBox "SELECT 文の実行時にエラーが発生しました。(DXSelect)" & Chr$(13) & Chr$(13) & _
　　　　　　"・Err.Description=" & Err.Description & Chr$(13) & _
　　　　　　"・SQL Text=" & strQuerySQL, _
　　　　　　vbExclamation, " 関数エラーメッセージ"
　　Resume Exit_DXSelect
End Function

No.16 回答者： f_a_007 回答日時： 2015/01/12 21:46

× DoCmd.RunSQL Replace(strRecord(I), XXXXX, strRecord(I))

〇 DoCmd.RunSQL Replace(strSQL, ”XXXXX”, strRecord(I))