エクセル VBA 同じ内容のセルの行を合わせたい

売上集計表があり、A列に全商品のコードが表示されてます。
毎日の売上商品のデータを商品コード別に数量を入力して同じ内容のセルの行の位置を合わせる作業を毎日行っています。
毎日の売上データはエクセルで集計されたデータを貼り付けて行っています。これをなんとかVBAで処理したいのですが、どうしたらいいのかわかりません。

内容としてはA列に全商品の商品コードが既に入力されています。
月のはじめは、B列とC列に一日の集計データそのまま貼り付けます。
A列の商品コードと同じ商品コードの行に合うまで空白のセルを挿入していきます。
次の日は、D列とＥ列、その次はＦ列とＧ列と右に貼り付けしていきます。
商品コードは約3000件、毎日の集計データ数は約500件です。
どうか教えてください。
完成例）
　　Ａ列　　　Ｂ列　　　Ｃ列　　　　　Ｄ列　　　　Ｅ列　　　　　　　Ｆ列　　　　Ｇ列　　　Ｈ列　　　Ｉ列
商品コード　　　　10/1分　　　　　　　　10/2分　　　　　　　　　　　　10/3分　　　　　　　10/4分・・・続く
　　　　　　　商品コード　数量　　　商品コード　数量　　　　　　商品コード数量
CZ1.000　　CZ1.000　　　10　　　　CZ1.000　　　20
CZ1.005　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　CZ1.010　　15　　　←セルの挿入で
CZ1.010　　CZ1.010　　　30　　　　　　　　　　　　　　　　　　　　CZ1.020 30　　　　下げる作業を
CZ1.015　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　CZ1.030　　10 毎日行ってます。
CZ1.020　　CZ1.020　　　11　　　CZ1.020　　　　20　　　　　　　CZ1.040　　40
CZ1.025
CZ1.030　　CZ1.030　　　11　　　CZ1.030　　　　10

よろしくお願いします。

No.1 ベストアンサー 回答者： ki-aaa 回答日時： 2012/11/14 09:14

こんにちわ

試してみて

Sub 商品コード配置()

Dim Dic商品コードと行 As Object
Dim 配列商品コード数量, 編集前商品コード数量
Dim 最終行 As Long
Dim i As Long, j As Long, k As Long
Dim 商品コード As String

Sheets("Sheet3").Activate '実際のシート名に変更
最終行 = Cells(Rows.Count, "A").End(xlUp).Row

配列商品コード数量 = Cells(3, "A").Resize(最終行 - 2, 1).Value
Set Dic商品コードと行 = CreateObject("Scripting.Dictionary")
For i = 1 To 最終行 - 2
Dic商品コードと行.Add 配列商品コード数量(i, 1), i
Next i

For i = (31 * 2) To 2 Step -2 '最大３１日　一日二列
ReDim 配列商品コード数量(1 To 最終行 - 2, 1 To 2)
k = Cells(Rows.Count, i).End(xlUp).Row
If k > 2 Then
編集前商品コード数量 = Cells(3, i).Resize(k - 2, 2).Value
For j = 1 To k - 2
商品コード = 編集前商品コード数量(j, 1)
If 商品コード <> "" Then
If Dic商品コードと行.exists(商品コード) Then
配列商品コード数量(Dic商品コードと行.Item(商品コード), 1) = 商品コード
配列商品コード数量(Dic商品コードと行.Item(商品コード), 2) = 編集前商品コード数量(j, 2)
Else
MsgBox "商品コード　" & 商品コード & "　に間違いがあります。"
End If
End If
Next j
Cells(3, i).Resize(最終行 - 2, 2).Value = 配列商品コード数量
End If
Next i

Set Dic商品コードと行 = Nothing
End Sub

この回答へのお礼

すぐに回答いただきまして有難うございます。
やりたいことにも、コード違いの対処まで
考えていただき、大変助かりました。(＾▽＾)♪

お礼日時：2012/11/17 09:18

No.2 回答者： mt2008 回答日時： 2012/11/14 22:47

3行の一番右に値がある列とその1つ左の列を対象に並び替えます。

あくまでもサンプルですのでエラー処理等は入れていません。あしからず。

Sub Sample()
　　Dim nData(), nPos()
　　Dim nRight, nDown, i
　　
　　'3行目一番右の列を対象
　　nRight = Cells(3, Columns.Count).End(xlToLeft).Column
　　nDown = Cells(Rows.Count, nRight).End(xlUp).Row
　　ReDim nData(nDown - 3)
　　ReDim nPos(nDown - 3)
　　For i = 0 To (nDown - 3)
　　　　'移動先の行をワークシート関数のMatchで調べる
　　　　nPos(i) = WorksheetFunction.Match(Cells(i + 3, nRight - 1), Range("A:A"), 0)
　　　　nData(i) = Cells(i + 3, nRight)
　　Next i
　　'元のデータを消す
　　Range(Cells(3, nRight - 1), Cells(nDown, nRight)).ClearContents
　　For i = 0 To (nDown - 3)
　　　　'移動先に代入
　　　　Cells(nPos(i), nRight - 1) = Cells(nPos(i), 1)
　　　　Cells(nPos(i), nRight) = nData(i)
　　Next i
End Sub

この回答へのお礼

ご回答いただき有難うございます。
やりたいことが、とても簡単に出来るようになりました。
大変、とっても助かりました。(＾▽＾)♪

お礼日時：2012/11/17 09:10