Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Excel 2016)
複数行のそれぞれの項目を1行にまとめたい
投稿日時: 18/04/25 13:46:30
投稿者: tyson

ゴールデンウィーク中の生徒の予定を、1件ごとにエクセルの入力してあります。
 
   4/28  4/29  4/30 
aくん △
aくん     ×   ×
bくん     △
bくん △
bくん         △
 
ある生徒は2件の予定があります。ほかのある生徒は3件の予定があります。
このような生徒100名のそれぞれ予定案件数がまちまちの予定印を、
1行にまとめて、その全部の予定(ここでは△印や×印を入力してます)もその1行に統合したいのです。
 
   4/28  4/29  4/30 
aくん △   ×   ×
bくん △   △   △
 
どのようなやり方がよろしいでしょうか?
 

回答
投稿日時: 18/04/25 14:15:15
投稿者: mattuwan44

   4/28  4/29  4/30  
aくん △   ×   × 
bくん △   △   △ 

 
こういう表をクロス集計表と呼びます。
エクセルではこういう表を作るには、
ピボットテーブルという機能を使います。
 
ただし、ピボットテーブルを使う前提条件として、
日付	氏名	予定
4月28日	aくん	△
4月28日	bくん	△
4月29日	bくん	△
4月30日	bくん	△

 
↑こういう1行1件のデータのリストを作っておくことが前提条件になります。
 
┌──────────┬────┬────┬────┐
│データの個数 / 予定 │列ラベル│        │        │
├──────────┼────┼────┼────┤
│行ラベル            │ 4月28日│ 4月29日│ 4月30日│
├──────────┼────┼────┼────┤
│aくん               │       1│        │        │
├──────────┼────┼────┼────┤
│bくん               │       1│       1│       1│
└──────────┴────┴────┴────┘

 
1とか空白とかを、△とか×とかに見せるには、セルの書式設定の表示形式に設定をすることで、
それなりに見せることが出来ると思います。
なのでそうやって使うのがいいとは思いますが、
 
それとも、今の表をマクロで自分ルールで加工したいということですか?

回答
投稿日時: 18/04/25 14:57:30
投稿者: mattuwan44

氏名が重複している部分をクリアして、
表中の空白セルを削除して上に詰めたら、
希望の表ですね。
小計機能を使ってキーブレークしている位置を特定してみました。
小計機能を使うのがまどろっこしいなら順に見て行ってクリアしてもいいと思います。
 
Sub test()
    Dim rngTable As Range
    Dim rngData As Range
    Dim rngTop As Range
    Dim a As Range
 
    With Range("A1").CurrentRegion
        '1列目で並び変える
        .Sort key1:=.Cells(1), Header:=xlYes
        '1列目をキーに小計行を仮に挿入する
        .Subtotal GroupBy:=1, Function:=xlCount, TotalList:=Array(2, 3, 4)
    End With
    '小計行が挿入されたのでセル範囲の再取得
    Set rngTable = Range("A1").CurrentRegion
    'データ部分のセル範囲を取得
    With rngTable
        Set rngData = Intersect(.Cells, .Offset(1), .Offset(, 1))
    End With
 
    Set rngTop = rngData.Rows(1)
    'データ部分の数式でない部分を取得重複している氏名をクリア
    For Each a In rngData.SpecialCells(xlCellTypeFormulas).Areas
        With Application.Range(rngTop, a.Offset(-1))
            .Resize(.Rows.Count - 1, 1).Offset(1, -1).ClearContents
        End With
        Set rngTop = a.Offset(1)
    Next
    '小計機能を解除
    rngTable.RemoveSubtotal
 
    '空白セルを削除(上に詰める)
    rngTable.Offset(1).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlShiftUp
End Sub

投稿日時: 18/04/25 15:15:44
投稿者: tyson

mattuwan44さん
 
すご技のてほどき、ありがとうございます。
早速手持ちのエクセルの表に適用と試みております
解決済みとさせていだきます