VBA 表の並び替え (追加質問)

先日表の並び替えでVBAを教えていただいたのですが、
できればもう少し詳しくご教授願いたいと思います。

【前回の質問】
同じ請求書内に含まれる情報をひとつの請求書列の横に並べて配置したいのですが。

請求書　製品　価格　 個数
aaa　　　AAA　　200　　10
aaa　　　BBB　　400　　10
aaa　　　CCC　　300　　5
bbb　　　AAA　　100　　50
bbb　　　BBB　　500　　10



請求書　製品　価格　 個数　製品　価格　 個数 製品　価格　 個数
aaa　　　AAA　　200　　10　BBB　　400　　10　　CCC　　300　　5
bbb　　　AAA　　100　　50　BBB　　500　　10

にたいして、

Sub test()
　Dim LastCol_1 As Long
　Dim LastCol_r As Long
　Dim LastCol_Max As Long
　Dim LastRow_A As Long
　Dim r As Long

　LastCol_1 = Cells(1, Columns.Count).End(xlToLeft).Column
　LastRow_A = Cells(Rows.Count, "A").End(xlUp).Row

　Application.ScreenUpdating = False
　'データの並べ替え
　For r = LastRow_A To 3 Step -1
　　LastCol_r = Cells(r, Columns.Count).End(xlToLeft).Column
　　If Range("A" & r).Value = Range("A" & r - 1).Value Then
　　　 Range("A" & r).Resize(, LastCol_r - 1).Offset(, 1).Copy _
　　　　 Destination:=Cells(r - 1, LastCol_1 + 1)
　　　 Rows(r).Delete
　　End If
　Next r
　
　'見出し行の編集
　With ActiveSheet.UsedRange
　　LastCol_Max = .Cells(.Cells.Count).Column
　End With
　Range("A" & 1).Resize(, LastCol_1 - 1).Offset(, 1).Copy _
　　　　 Destination:=Cells(1, LastCol_1 + 1).Resize(, LastCol_Max - LastCol_1)
　Application.ScreenUpdating = True
　
End Sub

というVBAコードをいただきました。
結果は大満足だったのすが、たとえばもし請求書columnの横に繰り返したくないcolumnがもう1列ある場合はどのようにしたらよいのでしょうか。請求書番号と同様1行に１回のみ表示させたいのです。

請求書　Year　製品　価格　 個数
aaa　　　2007　AAA　　200　　10
aaa　　　2007　BBB　　400　　10

↓↓↓↓↓↓↓↓↓

請求書　Year　製品　価格　 個数　製品　価格　 個数
aaa　　　2007　AAA　　200　　10　BBB　　400　　10　　

お手数ですが、コメントいただければ幸いです。

No.1 回答者： ka_na_de 回答日時： 2007/09/09 19:08

こんにちは。

以前回答した者です。

改良しましたので、お試しください。
尚、 左端の残したい列の数は変数にしたので、
以下の部分で変更できます。
IndexColNum = 2 '左端の残したい列の数




Sub test2()
　Dim LastCol_1 As Long
　Dim LastCol_r As Long
　Dim LastCol_Max As Long
　Dim LastRow_A As Long
　Dim r As Long
　Dim IndexColNum As Long
　
　IndexColNum = 2　　　'左端の残したい列の数

　LastCol_1 = Cells(1, Columns.Count).End(xlToLeft).Column
　LastRow_A = Cells(Rows.Count, "A").End(xlUp).Row

　Application.ScreenUpdating = False
　'データの並べ替え
　For r = LastRow_A To 3 Step -1
　　LastCol_r = Cells(r, Columns.Count).End(xlToLeft).Column
　　If Range("A" & r).Value = Range("A" & r - 1).Value Then
　　　 Range("A" & r).Resize(, LastCol_r - IndexColNum).Offset(, IndexColNum).Copy _
　　　　 Destination:=Cells(r - 1, LastCol_1 + 1)
　　　 Rows(r).Delete
　　End If
　Next r

　'見出し行の編集
　With ActiveSheet.UsedRange
　　LastCol_Max = .Cells(.Cells.Count).Column
　End With
　Range("A1").Resize(, LastCol_1 - IndexColNum).Offset(, IndexColNum).Copy _
　　　　 Destination:=Cells(1, LastCol_1 + 1).Resize(, LastCol_Max - LastCol_1)
　Application.ScreenUpdating = True

End Sub

No.2 回答者： ka_na_de 回答日時： 2007/09/09 19:39

＃１のka_na_deです。

上部の見出し行の数も変数にしておきました。


Sub test3()
　Dim LastCol_1 As Long
　Dim LastCol_r As Long
　Dim LastCol_Max As Long
　Dim LastRow_A As Long
　Dim r As Long
　Dim IndexColNum As Long
　Dim HeadLineNum As Long
　
　HeadLineNum = 1　　　'上部の見出し行の数
　IndexColNum = 2　　　'左端の残したい列の数

　LastCol_1 = Cells(1, Columns.Count).End(xlToLeft).Column
　LastRow_A = Cells(Rows.Count, "A").End(xlUp).Row


　Application.ScreenUpdating = False
　'データの並べ替え
　For r = LastRow_A To 2 + HeadLineNum Step -1
　　LastCol_r = Cells(r, Columns.Count).End(xlToLeft).Column
　　If Range("A" & r).Value = Range("A" & r - 1).Value Then
　　　 Range("A" & r).Resize(, LastCol_r - IndexColNum).Offset(, IndexColNum).Copy _
　　　　 Destination:=Cells(r - 1, LastCol_1 + 1)
　　　 Rows(r).Delete
　　End If
　Next r

　'見出し行の編集
　With ActiveSheet.UsedRange
　　LastCol_Max = .Cells(.Cells.Count).Column
　End With
　Range("A1").Resize(HeadLineNum, LastCol_1 - IndexColNum).Offset(, IndexColNum).Copy _
　　　　 Destination:=Cells(1, LastCol_1 + 1).Resize(, LastCol_Max - LastCol_1)
　Application.ScreenUpdating = True

End Sub

この回答へのお礼

ka_na_deさん、ありがとうございました。
まさに希望通りになりました！
実はVBAというものを前回の質問時まで知らなくて、
ネットで使い方を調べてみようみまねでやってみたのですが、
(実際はコピペさせていただいただけなのですが）
こんなすごいことが出来るのだととても感心しました。
ka_na_deさんのように自由自在に使える方がうらやましいです。

お礼日時：2007/09/11 23:28