• 締切済み

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   お手数ですが、コメントいただければ幸いです。

みんなの回答

  • ka_na_de
  • ベストアンサー率56% (162/286)
回答No.2

#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

shallowimp
質問者

お礼

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

  • ka_na_de
  • ベストアンサー率56% (162/286)
回答No.1

こんにちは。 以前回答した者です。 改良しましたので、お試しください。 尚、 左端の残したい列の数は変数にしたので、 以下の部分で変更できます。 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

関連するQ&A

専門家に質問してみよう