縦並びデータを横並びに加工(Excel、CSV)

以下のようなCSVデータがあります。
県名,品物名,購入者
青森,りんご,西田さん
青森,りんご,斉藤さん
青森,りんご,山田さん
愛媛,キウイ,島田さん
愛媛,みかん,石川さん
愛媛,みかん,佐藤さん
愛媛,みかん,田中さん
愛媛,みかん,小林さん
・
・
・


これを以下のように加工したいです。

県名,品物名,購入者1,購入者2,購入者3,購入者4・・・・・購入者100
青森,りんご,西田さん,斉藤さん,山田さん
愛媛,みかん,石川さん,佐藤さん,田中さん,小林さん
愛媛,キウイ,島田さん
・
・
・

要は、品物名でグループ化し、購入者の値を横並びにして項目名は連番にしたいです。
(項目名の連番は最後に手作業でも問題なし)
エクセルの手作業でならできましたが、品物名が500を超える場合があり、
購入者の数も100近くになるため、毎週こういうことはできないため、
エクセルやアクセスでなるべく簡単にできたらいいと思います。
スマートな方法のアイデアがあったらご教授ください。

No.5 ベストアンサー 回答者： tom04 回答日時： 2013/07/26 17:08

こんにちは！

VBAになってしまいますが、一例です。
Sheet1のデータをSheet2に表示するようにしてみました。

Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, endRow As Long, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1") '←「Sheet1」は実際のSheet名に！
Set wS2 = Worksheets("Sheet2") '←「Sheet2」も実際のSheet名に！
Application.ScreenUpdating = False
wS2.Cells.ClearContents
endRow = wS1.Cells(Rows.Count, "A").End(xlUp).Row
wS1.Range("A1").Resize(, 2).Copy wS2.Range("A1")
wS1.Range("A:A").Insert
With Range(wS1.Cells(1, "A"), wS1.Cells(endRow, "A"))
.Formula = "=B1&C1"
.Value = .Value
.AdvancedFilter Action:=xlFilterInPlace, unique:=True
End With
endRow = wS1.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS1.Cells(2, "B"), wS1.Cells(endRow, "C")).Copy wS2.Cells(2, "A")
With wS1
.ShowAllData
.Range("A:A").Delete
End With
For i = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
With wS1.Range("A1").CurrentRegion
.AutoFilter field:=1, Criteria1:=wS2.Cells(i, "A")
.AutoFilter field:=2, Criteria1:=wS2.Cells(i, "B")
endRow = .Cells(Rows.Count, "A").End(xlUp).Row
Range(.Cells(2, "C"), .Cells(endRow, "C")).Copy
wS2.Activate
ActiveSheet.Cells(i, "C").Select
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True
End With
Next i
For i = 3 To wS2.UsedRange.Columns.Count
wS2.Cells(1, i) = wS1.Cells(1, "C") & i - 2
Next i
Application.ScreenUpdating = True
wS1.AutoFilterMode = False
End Sub 'この行まで

こんなんではどうでしょうか？m（_ _）m

この回答へのお礼

ありがとうございます。
このソースのまま実現できてしまいました。
でもこんな見も知らず人の質問に、こうもパッとソースを書けてしまうスキルに感服です。
回答者さんにとってはそんな簡単な事なんでしょうか？

実は後から、C列に「種別」という項目が追加されてしまい(値は、野菜、果物等)、
購入者の列がD列に移動してしまいました。
ソースを手直ししてD列が横並びになるようにカスタマイズできましたが、

項目名と値が、
県名,品物名,購入者1,購入者2・・・
青森,りんご,果物,西田さん,斉藤さん
のように1列ずれてしまいました。

本当は
県名,品物名,種別,購入者1,購入者2・・・
青森,りんご,果物,西田さん,斉藤さん
としたいのですが・・・

それを解析するのが今後の課題です。
(教えてもらえると嬉しいです。)

お礼日時：2013/07/26 19:20

No.9 回答者： mitarashi 回答日時： 2013/07/29 22:00

#7です。

添付画像の様なデータで当方では動いているのですが．．．
いろいろやってみた中で、例えばA列の愛媛だけ入っていて、同じ行の他の列が空白といったケースではお示しのエラーが発生しました。この時、Sheet2には、途中まで抽出した中途半端なデータが入っておりましたが、そちらではいかがでしょうか。こちらの方法にも興味がおありなら、状況を教えて下さい。

この回答へのお礼

ご親切にありがとうございます。
今回はマクロの線で行きたいと思います。
またよろしくお願いいたします。

お礼日時：2013/07/30 14:54

No.8 回答者： tom04 回答日時： 2013/07/29 19:31

No.5・6です。

No.5に
＞「シート変換ボタン」というシートを作りそこにマクロ実行ボタンを置けたので、

というコトですが、
前回のコードは標準モジュールにして、
「マクロ実行ボタン」（←おそらくコマンドボタンだと思います）のコードを

Private Sub CommandButton1_Click()
Call Sample2
End Sub

としてみてもダメでしょうか？

※　Sample2　は前回のマクロ名ですので、
マクロ名を変えている場合はご自身でつけられたマクロ名にします。m（_ _）m

この回答へのお礼

はい。コマンドボタンのことです。
最初に教えていただいたマクロを加工して、何とか都合の良いものにすることができました。
ありがとうございます！

お礼日時：2013/07/30 14:54

No.7 回答者： mitarashi 回答日時： 2013/07/27 00:38

別の質問に触発されて、自ブックに対するADOでの抽出をやってみました。

xl2003以前については、自ブックに対して適用するとメモリリークが発生するというバグが放置されていて使えません。勤務先もそろそろxl2007以降のフォーマットが標準になりそうなので、復習してみました。
フィールド名決め打ちならもっとシンプルなコードになりますが、極力汎用化しようとトライしてみました。
後出しなので、「種別」にも対応しています。
なお、この方法ならアレンジすればCSVから直にできるかもしれませんが、上記の理由でSheet1に読み込んでからの処理です。
Const adOpenFowardOnly As Long = 0

Sub test()
Dim cn As Object
Dim rs0 As Object, rs As Object, rs2 As Object
Dim mySQL As String, mySQL2 As String
Dim destRange As Range
Dim i As Long, j As Long

Set cn = CreateObject("ADODB.Connection")
With cn
.Provider = "Microsoft.ace.OLEDB.12.0"
.connectionstring = "Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties='Excel 12.0; HDR=YES'"
.Open
End With
'rs0 フィールド名取得用
Set rs0 = CreateObject("ADODB.Recordset")
rs0.Open "SELECT * FROM [Sheet1$];", cn, adOpenFowardOnly
'rs グループ化したRecordset
Set rs = CreateObject("ADODB.Recordset")
mySQL = "SELECT F1,F2,F3 FROM [Sheet1$] GROUP BY F1,F2,F3;"
For i = 1 To 3
mySQL = Replace(mySQL, "F" & CStr(i), rs0.Fields(i - 1).Name)
Next i
rs.Open mySQL, cn, adOpenFowardOnly

Sheets("Sheet2").Cells.Clear
Set destRange = Sheets("Sheet2").Range("A2")
For i = 1 To 3
destRange.Offset(, i - 1).Item(0) = rs0.Fields(i - 1).Name
Next i
For i = 1 To 100
destRange.Offset(, 2 + i).Item(0) = rs0.Fields(3).Name & CStr(i)
Next i
Do Until rs.EOF
For i = 0 To 2
destRange.Offset(, i).Value = rs.Fields(i).Value
Next i
mySQL2 = "SELECT F4 FROM [Sheet1$] WHERE F1='F1Value' AND F2 = 'F2Value' AND F3 = 'F3Value';"
For i = 1 To 4
If i < 4 Then mySQL2 = Replace(mySQL2, "F" & CStr(i) & "Value", rs.Fields(i - 1).Value)
mySQL2 = Replace(mySQL2, "F" & CStr(i), rs0.Fields(i - 1).Name)
Next i
'rs2 グループ化した組み合わせ毎に該当するリストを取得
Set rs2 = CreateObject("ADODB.Recordset")
rs2.Open mySQL2, cn, adOpenFowardOnly
j = 3
Do Until rs2.EOF
destRange.Offset(, j).Value = rs2.Fields(0).Value
rs2.MoveNext
j = j + 1
Loop
Set rs2 = Nothing
rs.MoveNext
Set destRange = destRange.Offset(1, 0)
Loop
Set rs0 = Nothing
Set rs = Nothing
cn.Close: Set cn = Nothing
End Sub

この回答へのお礼

ありがとうございます。
しかし実行すると「nullの使い方が不正です。」というエラーが出てしまい、
以下の行が黄色いマーカーになりました。

mySQL2 = Replace(mySQL2, "F" & CStr(i) & "Value", rs.Fields(i - 1).Value)

お礼日時：2013/07/29 11:25

No.6 回答者： tom04 回答日時： 2013/07/26 22:35

No。

5です。

＞本当は
＞県名,品物名,種別,購入者1,購入者2・・・

というコトはSheet1が↓の画像のような配置になっているという前提です。

前回は時間がなかったので慌ててコードを作ってしまいました。
前回とはちょっと違いますが、↓のコードでマクロを試してみてください。

Sub Sample2()
Dim i As Long, j As Long, endRow As Long, lastRow As Long, endCol As Long
Dim wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Application.ScreenUpdating = False
wS2.Cells.ClearContents
With wS1
.Range("A1").Resize(, 3).Copy wS2.Range("A1")
endRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").Insert
With .Range("A1").Resize(endRow)
.Formula = "=B1&C1"
.Value = .Value
End With
.Range(Cells(1, "A"), Cells(endRow, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range(Cells(2, "B"), Cells(lastRow, "D")).Copy wS2.Cells(2, "A")
.ShowAllData
.Range("A:A").Delete
For i = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1").AutoFilter field:=1, Criteria1:=wS2.Cells(i, "A")
.Range("A1").AutoFilter field:=2, Criteria1:=wS2.Cells(i, "B")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Range(.Cells(2, "D"), .Cells(lastRow, "D")).Copy
wS2.Activate
ActiveSheet.Cells(i, "D").Select
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True
Next i
endCol = wS2.UsedRange.Columns.Count
For j = 4 To endCol
wS2.Cells(1, j) = .Range("D1") & j - 3
Next j
End With
wS1.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub

今度はどうでしょうか？m（_ _）m

この回答へのお礼

ありがとうございます。
問題点が解決されていて完ぺきでした！
ただ一つ残念なのが、
sheet1をアクティブにした状態でマクロを実行しないとエラーになってしまう点です。

前回の場合は、別のシートがアクティブになっていても、
sheet1を加工してsheet2に書き出してくれていたので、
「シート変換ボタン」というシートを作りそこにマクロ実行ボタンを置けたので、
開発タブを出していないユーザでも実行できるようにできていました。

自分でソースが読めるようになりたいです。

お礼日時：2013/07/29 11:29

No.4 回答者： kuma310min 回答日時： 2013/07/26 16:13

(1)CSVファイル（仮にtest.csvとする）を、Excelで開く。

D2→　=A2&B2、　E2→　=COUNTIF($D$2:D2,D2)、　F2→　=D2&E2
を入力し、必要なだけ下へコピー。


(2)以下のような数式の入ったBook1（予め作成しておくと便利）を開く
・１行目は、予め入力
A2→　=IF(test.csv!$E2=1,test.csv!A2,"")
B2→　=IF(test.csv!$E2=1,test.csv!B2,"")
必要なだけ下へコピー。

C2→　=IFERROR(OFFSET(test.csv!$F$1,MATCH($A2&$B2&COLUMN()-2,test.csv!$F$2:$F$9,0),-3),"")
必要なだけ、右方向・下方向へコピー。

(3)並べ替え等で、空白行を詰める

※バージョンによっては、IFERRORは使えないかもしれません。

この回答へのお礼

ありがとうございます。
後で試してみたいと思います。
助かりました。

お礼日時：2013/07/26 19:12

No.3 回答者： mike_g 回答日時： 2013/07/26 14:52

[No.2]に示した配列数式は間違いではないけど、少し冗長な箇処がありました。

「Sheet1!」を２箇処削除した次式でもＯＫです。
{=INDEX(Sheet1!$C$1:$C$50000,SMALL(IF((Sheet1!$A$1:$A$50000=$A2)*(Sheet1!$B$1:$B$50000=$B2),(Sheet1!$A$1:$A$50000=$A2)*(Sheet1!$B$1:$B$50000=$B2)*ROW(A$1:A$50000),""),COLUMN(A1)))}

私の回答が難解過ぎる場合は無視して下さい。補足説明するのが面倒なので。

No.2 回答者： mike_g 回答日時： 2013/07/26 14:43

数式が　　　=ISERROR(C2)

フォント色　白
の[条件付き書式]を設定した Sheet2 のセル C2 に次の配列数式を入力し、此れをズズーッと右および下方にドラッグ＆ペースト
{=INDEX(Sheet1!$C$1:$C$50000,SMALL(IF((Sheet1!$A$1:$A$50000=$A2)*(Sheet1!$B$1:$B$50000=$B2),(Sheet1!$A$1:$A$50000=$A2)*(Sheet1!$B$1:$B$50000=$B2)*ROW(Sheet1!A$1:A$50000),""),COLUMN(Sheet1!A1)))}

なお、Sheet2 の列Ａ、Ｂのデータは、例えば次のような方法で、事前に作成しておく。
先ず、ピボットテーブルを利用すれば、Fig-1 のデータが簡単に作成できる。
それを Fig-2 のように加工するのも簡単！

この回答へのお礼

ありがとうございます。
関数を使いこなす方法ですね。
解析して応用できるようにします。
今回はマクロで簡単に済ます方法にします。

お礼日時：2013/07/26 19:11

No.1 回答者： sknbsknb2 回答日時： 2013/07/26 14:27

とりあえず省力化できる方法を考えてみました。

(1)A2,B2,C2から縦にデータを入力する。A2="青森",B2="りんご",C2="西田さん"という具合。
(2)D2に、
=IF(A1&B1=A2&B2,D1&","&C2,C2)
　という数式を入れて、縦方向にコピーする。(列Cにデータの存在する行すべて)
(3)E2に
=IF(A2&B2<>A3&B3,D2,"")
　という数式を入れて、縦方向にコピーする。(列Cにデータの存在する行すべて)
(4)列A-Eのデータをコピーし、別のシートに
形式を選択して貼り付け->値
　を使って、値として貼り付ける。
(5)貼りつけたのがA1からとして、列A-Eを列E基準で並べ替える。
(6)列Eにデータがあるものだけがまとまっているので、それ以外の行を削除する。
(7)列Dを削除する。
(8)列Dを選択して、
区切り位置->カンマ区切り
　でデータを分割する。
(9)列Cを削除する。

　品物名が同じでも県名が違うものは別に集計するようになっていますので、品物名だけで
いい場合は計算式を変更してください。

この回答へのお礼

ありがとうございます。
マクロとか特殊な方法を使わずとも、手順を追っていけばできる堅実な方法ですね。
参考にさせていただきました。

お礼日時：2013/07/26 19:10