Excel VBA質問箱 IV

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

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


72840 / 76732 ←次へ | 前へ→

【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
1 hits

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

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