- 締切済み
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行に1回のみ表示させたいのです。 請求書 Year 製品 価格 個数 aaa 2007 AAA 200 10 aaa 2007 BBB 400 10 ↓↓↓↓↓↓↓↓↓ 請求書 Year 製品 価格 個数 製品 価格 個数 aaa 2007 AAA 200 10 BBB 400 10 お手数ですが、コメントいただければ幸いです。
- みんなの回答 (2)
- 専門家の回答
みんなの回答
- ka_na_de
- ベストアンサー率56% (162/286)
#1の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
- ベストアンサー率56% (162/286)
こんにちは。 以前回答した者です。 改良しましたので、お試しください。 尚、 左端の残したい列の数は変数にしたので、 以下の部分で変更できます。 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
お礼
ka_na_deさん、ありがとうございました。 まさに希望通りになりました! 実はVBAというものを前回の質問時まで知らなくて、 ネットで使い方を調べてみようみまねでやってみたのですが、 (実際はコピペさせていただいただけなのですが) こんなすごいことが出来るのだととても感心しました。 ka_na_deさんのように自由自在に使える方がうらやましいです。