| |
こんなやり方かな？
ただし、「その月の出席数」が全員無い場合その列は作られません
以下を標準モジュールに記述して下さい
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
'１行配列に読み込み
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
'書き込み行の第１列に「生徒の出席番号」を書き込む
.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
|
|
Hirofumi
- 03/10/12(日) 8:33 -
