Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


12839 / 13644 ツリー ←次へ | 前へ→

【8373】出席状況管理表を作りたいのですが・・・ 乾燥肌 03/10/12(日) 1:25 質問
【8374】Re:出席状況管理表を作りたいのですが・・・ Hirofumi 03/10/12(日) 8:33 回答
【8375】ありがとうございました 乾燥肌 03/10/13(月) 0:01 お礼

【8373】出席状況管理表を作りたいのですが・・・
質問  乾燥肌  - 03/10/12(日) 1:25 -

引用なし
パスワード
   教えて欲しいことがあり、投稿させて頂きました。
よろしくお願いします。

EXCELのシート1に、A列から順に
A列「生徒の出席番号」(integer 昇順 無い番号もいます)
B列「年度・月」(integer 古いものから順に ※例 15年10月なら 1510)
C列「その月の出席数」(integer)
が入っています。

A    B    C
1   1401   20
1   1402   15
1   1404   18
2   1402   13
2   1404   15
4   1402   15   という状態です。

このデータを、シート2に抽出したいのですが、
月毎に、後でコメントを書き込みたいので、1列ずつ空け、

A    B   C   D   E   F   G   H
    1401    1402    1403    1404
1   20       15             18
2           13             15
4           15

という並びになるよう、組んでみたいと思ったのですが、
どうにも上手くいきません。
ご参考までに、教えていただけると有り難いです。
よろしくお願いします。   

【8374】Re:出席状況管理表を作りたいのですが・・...
回答  Hirofumi E-MAIL  - 03/10/12(日) 8:33 -

引用なし
パスワード
   こんなやり方かな?
ただし、「その月の出席数」が全員無い場合その列は作られません
以下を標準モジュールに記述して下さい

Option Explicit

Public Sub Classification()

  Dim i As Long
  Dim vntData As Variant
  Dim wksWrite As Worksheet
  Dim lngWriteRow As Long
  Dim vntRowKey As Variant
  Dim wksRead As Worksheet
  Dim lngRow As Long
  Dim lngTop As Long
  Dim lngEnd As Long
  Dim lngFound As Long
  Dim lngOver As Long

  '読み込むシートを設定
  Set wksRead = Worksheets("Sheet1")
  
  '書き込むシートを設定
  Set wksWrite = Worksheets("Sheet2")
  '「年度・月」の見だし行を設定
  lngRow = 1
  '「年度・月」の先頭列を設定
  lngTop = 2
  '「年度・月」の最終列を設定
  lngEnd = 2
  '書き込み行を設定
  lngWriteRow = 1
  
  For i = 1 To wksRead.Cells(65536, 1).End(xlUp).Row
    '1行配列に読み込み
    With wksRead
      vntData = Range(.Cells(i, 1), .Cells(i, 3)).Value
    End With
    'シートに書き込み
    With wksWrite
      '「年度・月」列を探索
      lngFound = ColumnSearch(vntData(1, 2), _
              .Cells(lngRow, _
                lngTop).Resize(, lngEnd), lngOver)
      '「年度・月」が見つからない場合
      If lngFound = 0 Then
        '挿入位置に列を挿入
        .Columns(lngOver).Insert
        '発見位置を挿入位置に
        lngFound = lngOver
        '挿入位置に「年度・月」を書き込み
        .Cells(lngRow, lngFound).Value = vntData(1, 2)
        '「年度・月」列の最終列を更新
        lngEnd = lngEnd + 1
      End If
      'もし、前の「生徒の出席番号」と違うなら
      If vntData(1, 1) <> vntRowKey Then
        '書き込み行を更新
        lngWriteRow = lngWriteRow + 1
        '書き込み行の第1列に「生徒の出席番号」を書き込む
        .Cells(lngWriteRow, 1).Value = vntData(1, 1)
        '前の「生徒の出席番号」を更新
        vntRowKey = vntData(1, 1)
      End If
      '「生徒の出席番号」行と「年度・月」列の交差するセルに
      '「その月の出席数」を書き込み
      .Cells(lngWriteRow, lngFound).Value = vntData(1, 3)
    End With
  Next i
  'コメントを書く列を挿入
  With wksWrite
    For i = lngEnd - 1 To lngTop + 1 Step -1
      .Columns(i).Insert
    Next i
  End With
  
  '読み込むシートの参照を破棄
  Set wksRead = Nothing
  '書き込むシートの参照を破棄
  Set wksWrite = Nothing

End Sub

Private Function ColumnSearch(vntKey As Variant, _
            rngScope As Range, _
            Optional lngOver As Long) As Long

  Dim vntFind As Variant
  Dim lngDataTop As Long
  
  '範囲先頭列位置
  lngDataTop = rngScope.Column
  lngOver = lngDataTop
  'Matchによる二分探索
  vntFind = Application.Match(vntKey, rngScope, 1)
  'もし、エラーで無いなら
  If Not IsError(vntFind) Then
    'もし、Key値と探索位置の値が等しいなら
    If vntKey = rngScope(1, vntFind).Value Then
      '戻り値として、列位置を代入
      ColumnSearch = lngDataTop + vntFind - 1
    End If
    'Key値を超える最小値のある列
    lngOver = lngDataTop + vntFind
  Else
    lngOver = lngDataTop
  End If
  
End Function

【8375】ありがとうございました
お礼  乾燥肌  - 03/10/13(月) 0:01 -

引用なし
パスワード
   Hirofumi様
ご回答、ありがとうございました。
拝見させて頂きましたが、とても複雑ですね・・・。
私が作成していたものなど、子供の遊びのようです。
早速、標準モジュールに書き込み、試させて頂きます。
また、不明な点がありましたら、是非よろしくお願いします。
今回は、本当にありがとうございました。

12839 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free