| |
列の挿入、1つづつのセルへのアクセスを行うので速い処理では有りませんが
尚、データListはSheet1のA1から有る物とし、結果はSheet2のA1を先頭として出力します
また、結果の月は、月初（例えば、2005/1/1）のシリアル値が入る物とします
Option Explicit
Public Sub CrossTabulation()
'データ列数(A列〜C列)
Const clngColumns As Long = 3
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim vntData As Variant
Dim rngResult As Range
Dim rngDate As Range
Dim rngScope As Range
Dim lngColumn As Long
Dim lngRow As Long
Dim vntMonth As Variant
Dim strProm As String
'データListの左上隅セル位置を基準として設定(列見出しの「日付」セル位置)
Set rngList = Worksheets("Sheet1").Cells(1, "A")
With rngList
'データ行数を取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
'データが無い場合
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'データを配列に取得
vntData = .Offset(1).Resize(lngRows + 1, clngColumns).Value
End With
'結果出力シートのA1セルを基準とする（Listの左上隅）
Set rngResult = Worksheets("Sheet2").Cells(1, "A")
With rngResult
'日付の書かれている列数を取得
lngColumn = .Offset(, Columns.Count - _
.Column).End(xlToLeft).Column - .Column
'日付列の範囲を取得
If lngColumn > 0 Then
Set rngDate = .Offset(, 1).Resize(, lngColumn)
End If
'品名が有る行数を取得
lngRow = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
'品名が有る範囲を取得
If lngRow > 0 Then
Set rngScope = .Offset(1).Resize(lngRow)
End If
End With
'画面更新を停止
Application.ScreenUpdating = False
'データの最終行まで繰り返し
For i = 1 To lngRows
'日付のシリアル値から月初の値を取得
vntMonth = DateSerial(Year(vntData(i, 1)), Month(vntData(i, 1)), 1)
'日付を探索
lngColumn = GetColumnPos(vntMonth, rngDate, rngResult)
'品名を探索
lngRow = GetRowPos(vntData(i, 2), rngScope, rngResult)
'日付、品名の交差するセルに値を書き込み
With rngResult.Offset(lngRow, lngColumn)
.NumberFormatLocal = "#,##0;""▲ ""#,##0"
.Value = .Value + vntData(i, 3)
End With
Next i
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
Set rngScope = Nothing
Set rngDate = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function GetColumnPos(vntDate As Variant, _
rngScope As Range, _
rngDateTop As Range) As Long
Dim lngFound As Long
Dim lngOver As Long
Dim lngCount As Long
'日付範囲に日付が無いなら
If rngScope Is Nothing Then
lngFound = 0
lngCount = 0
lngOver = 1
Else
'日付の探索
'セル値が数値として入力されている場合
lngFound = DataSearch(CLng(vntDate), rngScope, lngOver)
'セル値が文字列として入力されている場合
' lngFound = DataSearch(vntDate, rngScope, lngOver)
lngCount = rngScope.Columns.Count
End If
'日付が見つかった場合
If lngFound > 0 Then
'位置を返す
GetColumnPos = lngFound
Else
With rngDateTop
'日付が最終列の以内の場合
If lngOver <= lngCount Then
'指定位置に列を挿入
.Offset(, lngOver).EntireColumn.Insert
End If
'日付を書き込み
With .Offset(, lngOver)
.NumberFormatLocal = "yyyy/m"
' .NumberFormatLocal = "m""月"""
.Value = vntDate
End With
'挿入位置を返す
GetColumnPos = lngOver
'日付列の範囲を更新
Set rngScope = .Offset(, 1).Resize(, lngCount + 1)
End With
End If
End Function
Private Function GetRowPos(vntKey As Variant, _
rngScope As Range, _
rngListTop As Range) As Long
Dim lngFound As Long
Dim lngCount As Long
'品名範囲に品名が無いなら
If rngScope Is Nothing Then
lngFound = 0
lngCount = 0
Else
'品名を探索
lngFound = DataSearch(vntKey, rngScope, , 0)
lngCount = rngScope.Rows.Count
End If
'探索成功（品名が有るなら）
If lngFound > 0 Then
'位置を返す
GetRowPos = lngFound
Else
With rngListTop
'行末位置を更新
lngCount = lngCount + 1
'セルの書式を文字列に設定
'(001の様な場合無いと探索が出来ない）
.Offset(lngCount).NumberFormatLocal = "@"
'行末に品名を書き込み
.Offset(lngCount).Value = vntKey
'挿入位置を返す
GetRowPos = lngCount
'探索範囲の更新
Set rngScope = .Offset(1).Resize(lngCount)
End With
End If
End Function
Private Function DataSearch(vntKey As Variant, _
rngScope As Range, _
Optional lngOver As Long, _
Optional lngMode As Long = 1) As Long
Dim vntFind As Variant
'Matchによる二分探索
vntFind = Application.Match(vntKey, rngScope, lngMode)
lngOver = 1
'もし、エラーで無いなら
If Not IsError(vntFind) Then
'もし、Key値と探索位置の値が等しいなら
If vntKey = rngScope(vntFind).Value Then
'戻り値として、行位置を代入
DataSearch = vntFind
End If
'Key値を超える最小値のある行
lngOver = vntFind + 1
End If
End Function
|
|
Hirofumi
- 06/9/9(土) 9:08 -
