エクセルで重複データの内容を右の列に増やす方法は？

エクセル２００７で、表(1)のようなレコードがあります。
Ｂ列とＣ列の両列をキー列として、両列が次の行と同じ場合、表(2)のように一行にまとめるＶＢＡを、どなたかご教示お願いします。
過去ログ等で重複データの行削除は理解できたのですが、キー列が２列の場合や、表(2)のように右の列にデータをどんどん増やす方法がわかりません。
条件は、レコードは1０００行以上、市idと社idは昇順に並んでいるため重複データは必ず上下に連続している、商品の種類は５０以上あり、どれ位右に列が増えるか不明、などです。
ＶＢＡ初心者です。よろしくお願いします。

表(1)（sheet1）
県名｜市id ｜ 社id｜社名｜商品｜空白｜空白・・
秋田｜0001｜0001｜Ａ株｜青大｜空白
秋田｜0001｜0001｜Ａ株｜赤小｜空白
東京｜0002｜0003｜Ｂ株｜黒中｜空白
大阪｜0004｜0001｜Ｃ有｜赤中｜空白
大阪｜0004｜0001｜Ｃ有｜白大｜空白
大阪｜0004｜0002｜Ｄ株｜赤大｜空白
大阪｜0004｜0002｜Ｄ株｜黄中｜空白
大阪｜0004｜0002｜Ｄ株｜緑小｜空白
・
・

表(2)（sheet2）
県名｜市id｜ 社id｜社名｜商品｜商品｜商品・・
秋田｜0001｜0001｜Ａ株｜青大｜赤小｜空白
東京｜0002｜0003｜Ｂ株｜黒中｜空白｜空白
大阪｜0004｜0001｜Ｃ有｜赤中｜白大｜空白
大阪｜0004｜0002｜Ｄ株｜赤大｜黄中｜緑小
・
・

No.3 ベストアンサー 回答者： cj_mover 回答日時： 2013/05/16 00:16

＃２補足欄へのレスです。

エラーが出るとのこと。
掲示されている＃２のコードをコピーして再度繰り返し確認しましたが、
こちらでは問題なく処理できています。
記述の通りでテストしているのであれば、実際のシートのあり方と
こちらが想定しているものとが違っているのかも知れませんね。

まず、
> 最後から７行目、　.Select　だけでいいのでしょうか。
はい、合っています。
もしここがエラーになっている？、ということですと、
標準モジュールに貼るべきところをSheet1モジュールに貼っているとかですかね？
特に断りがない場合は、マクロは標準モジュールに記述するものです。
私がちゃんと説明しておけば良かったですね。
ちょっと不親切でした。すみません。
対策として以下、
標準モジュールに貼って実行するか、または、Sheet1モジュールのまま
最後の23行分を以下の25行に差し替えてみてください。

　　 Application.ScreenUpdating = False
　　 With Sheets("Sheet2")
　　　　 .Select ' ←要指定　出力シート名［ "Sheet2" ？］
　　　　 .Cells.ClearContents
　　　　 rngS.Copy
　　　　 .Cells(1).PasteSpecial xlPasteColumnWidths
　　　　 .Cells.Resize(nPrtRow, tnCols).PasteSpecial xlPasteFormats
　　　　 If VarType(rngS(2, 2).Value) = vbString And rngS(2, 2).NumberFormat = "General" Then
　　　　　　　　.Range("B2:C" & nPrtRow).NumberFormat = "@"
　　　　 End If
　　　　 If nPrtXSize > tnCols Then
　　　　　　　　.Columns(tnCols).Copy
　　　　　　　　.Columns(tnCols + 1).Resize(, nPrtXSize - tnCols).PasteSpecial xlPasteFormats
　　　　 End If
　　　　 With .Cells.Resize(nPrtRow, nPrtXSize)
　　　　　　　　.Value = mtxP()
　　　　　　　　.Select
　　　　 End With
　　 End With
　　 Application.CutCopyMode = False

　　Application.ScreenUpdating = True
　　Erase mtxP()
　　Set rngS = Nothing
End Sub



以上で解決が得られた場合は、以下読まなくて結構です。

> 試してみたところ、エラーになってしまいました。
どの行でエラーになっているか確認できますか？
エラーメッセージが表示されたら、[デバッグ]ボタンを押してみてください。
エラーの原因になっている行が黄色くハイライトされますので、
その行の記述とエラーメッセージの内容を教えてください。
↑エラー相談時のルーティンです。

とりあえず、他に原因として思い付く点だけ、


１）元データシートでシートの保護を適用している場合
　　→　一旦シートの保護を解除して試してみる。


２）元データシートの６列目、例示では空白列だけど、本当は違っている場合

' ' 要指定　元データシート名↓［ "Sheet1" ？］
　　Set rngS = Sheets("Sheet1").Cells(2, 2).CurrentRegion
　　mtxS() = rngS.Value
　　tnRows = UBound(mtxS())
　　tnCols = UBound(mtxS(), 2)

　↑この４行を以下の4行に差し替えて試してみる

　　tnCols = 5
　　Set rngS = Sheets("Sheet1").Cells(2, 2).CurrentRegion.Resize(, 5)
　　mtxS() = rngS.Value
　　tnRows = UBound(mtxS())


３）要指定と書かれた部分の指定を確認する。

' ' 要指定　元データシート名↓［ "Sheet1" ？］
　→　元データのシート名は　"Sheet1"　で合っていますか？

　　ReDim mtxP(1 To tnRows, 1 To 100) ' ←要指定　最大列数［ 100 ？］
　→　"商品"項目が右に並んで95品目を超える可能性があれば、
　　　100 の数値を増やして対応してみてください。

　　Sheets("Sheet2").Select ' ←要指定　出力シート名［ "Sheet2" ？］
　→　出力先のシート名は　"Sheet2"　で合っていますか？


／／／／／

こちらも慎重さとか配慮が足らなかったかも知れません。
> 初心者の質問ですいません。
どうか、お気になさらず、、、。
更にお困りでしたら、遠慮なく訊いてください。

以上です。

この回答へのお礼

できました！
Sheet1モジュールに貼っていました。的確なアドバイス、ありがとうございました。
処理速度も申し分ありません。
感謝、感謝です！

お礼日時：2013/05/16 00:47

No.2 回答者： cj_mover 回答日時： 2013/05/15 14:58

＃１、ｃｊです。

出力側の書式全般についてケアしたものを書いてみました。
数字文字列の扱いは十分なものになっていると思います。
（↑これ、結構混乱する人多いので、、、。）
その他の書式や列幅は元データシートを反映します。

"商品"の羅列、追加しました。

メインの処理は、配列変数を使って多少速くなります。
（書式処理で時間を喰うので調整の意味で替えました。）
諸々、難度はグっと上がって中級ぐらいですが、
レコード数が増えても殆どストレスないと思います。

各IDのソートは確実という前提です。
元データは何列あっても構いませんが、
連続した範囲の最右の列に"商品"項目列がひとつだけあることが条件になります。
元データの"商品"項目が複数列の場合も考えましたが、今回は対応しません。

各IDの数字文字列に関する注意点として、、
【文字列値"0001"】と【数値1、表示0001】のセルが混在している場合は、
別件として扱われます。

実際のシートで試してみないと、（お互いに）勝手がわからないと思いますが、
具体的な追加要件あれば、もう一度書きます。


Sub Re8087776j()
　　Dim rngS As Range ' 元データ範囲
　　Dim mtxS() ' 元データ配列
　　Dim mtxP() ' 出力用データ配列
　　Dim tnRows As Long ' 元データ 行数
　　Dim tnCols As Long ' 元データ　列数
　　Dim iR As Long ' 元データ　行位置
　　Dim iC As Long ' 元データ　列位置
　　Dim nPrtRow As Long ' 出力先　行位置
　　Dim nPrtCol As Long ' 出力先　列位置
　　Dim nPrtXSize As Long ' 出力先　列総数
　　Dim sTmp As String ' 元データの連結キー
　　Dim sKeyMrg As String ' 出力行の連結キー

' ' 要指定　元データシート名↓［ "Sheet1" ？］
　　Set rngS = Sheets("Sheet1").Cells(2, 2).CurrentRegion
　　mtxS() = rngS.Value
　　tnRows = UBound(mtxS())
　　tnCols = UBound(mtxS(), 2)

　　ReDim mtxP(1 To tnRows, 1 To 100) ' ←要指定　最大列数［ 100 ？］
　　For iR = 1& To tnRows
　　　　sTmp = mtxS(iR, 2) & vbLf & mtxS(iR, 3)
　　　　If sTmp = sKeyMrg Then
　　　　　　nPrtCol = nPrtCol + 1&
　　　　　　mtxP(nPrtRow, nPrtCol) = mtxS(iR, tnCols)
　　　　　　If nPrtCol > nPrtXSize Then nPrtXSize = nPrtCol
　　　　Else
　　　　　　nPrtRow = nPrtRow + 1&
　　　　　　For iC = 1& To tnCols
　　　　　　　　mtxP(nPrtRow, iC) = mtxS(iR, iC)
　　　　　　Next iC
　　　　　　sKeyMrg = sTmp
　　　　　　nPrtCol = tnCols
　　　　End If
　　Next iR
　　Erase mtxS()

　　For iC = tnCols + 1& To nPrtXSize
　　　　mtxP(1, iC) = mtxP(1, tnCols)
　　Next iC

　　Application.ScreenUpdating = False
　　Sheets("Sheet2").Select ' ←要指定　出力シート名［ "Sheet2" ？］
　　Cells.ClearContents
　　rngS.Copy
　　Cells(1).PasteSpecial xlPasteColumnWidths
　　Cells.Resize(nPrtRow, tnCols).PasteSpecial xlPasteFormats
　　If VarType(rngS(2, 2).Value) = vbString And rngS(2, 2).NumberFormat = "General" Then
　　　　Range("B2:C" & nPrtRow).NumberFormat = "@"
　　End If
　　If nPrtXSize > tnCols Then
　　　　Columns(tnCols).Copy
　　　　Columns(tnCols + 1).Resize(, nPrtXSize - tnCols).PasteSpecial xlPasteFormats
　　End If
　　With Cells.Resize(nPrtRow, nPrtXSize)
　　　　.Value = mtxP()
　　　　.Select
　　End With
　　Application.CutCopyMode = False

　　Application.ScreenUpdating = True
　　Erase mtxP()
　　Set rngS = Nothing
End Sub

この回答への補足

回答ありがとうございます。
試してみたところ、エラーになってしまいました。
最後から７行目、　.Select　だけでいいのでしょうか。
初心者の質問ですいません。

補足日時：2013/05/15 22:53

No.1 回答者： cj_mover 回答日時： 2013/05/14 21:18

こんにちは。

1000行ほど、ということなので、解り易さ優先のコードを書いてみました。
項目名"商品"の羅列は省略します。
技術的には
　For ... Next ループ
　変数の扱い
　Rangeの扱い
と、初級の内容で統一しています。
何か不足や疑問などありましたら、具体的に補足してみてください。

Sub Re8087776()
　　Dim rngS As Range ' 元データ範囲
　　Dim tnRows As Long ' 元データ 行数
　　Dim tnCols As Long ' 元データ　列数
　　Dim iR As Long ' 元データ　行位置
　　Dim iC As Long ' 元データ　列位置
　　Dim nPrtRow As Long ' 出力先　行位置
　　Dim nPrtCol As Long ' 出力先　列位置
　　Dim sTmp As String ' 元データの連結キー
　　Dim sKeyMrg As String ' 出力行の連結キー

' ' 要列数指定↓
　　tnCols = 5
' ' 　　　　　　要シート指定↓
　　Set rngS = Sheets("Sheet1").Cells(2, 2).CurrentRegion.Resize(, tnCols)
　　tnRows = rngS.Rows.Count
　　Application.ScreenUpdating = False
' ' 要シート指定↓
　　Sheets("Sheet2").Select
　　For iR = 1 To tnRows
　　　　sTmp = rngS.Cells(iR, 2) & Format(rngS.Cells(iR, 3), "0000")
　　　　If sTmp = sKeyMrg Then
　　　　　　nPrtCol = nPrtCol + 1
　　　　　　Cells(nPrtRow, nPrtCol) = rngS.Cells(iR, tnCols)
　　　　Else
　　　　　　sKeyMrg = sTmp
　　　　　　nPrtRow = nPrtRow + 1
　　　　　　nPrtCol = tnCols
　　　　　　For iC = 1 To tnCols
　　　　　　　　Cells(nPrtRow, iC) = rngS.Cells(iR, iC)
　　　　　　Next iC
　　　　End If
　　Next iR
　　Application.ScreenUpdating = True
　　Set rngS = Nothing
End Sub