| |
こんな物かな？
Option Explicit
Public Sub AddUp()
Dim i As Long
Dim vntData As Variant
Dim rngListTop As Range
Dim rngScopeCol As Range
Dim rngColItem As Range
Dim lngColNum As Long
Dim rngScopeRow As Range
Dim rngRowItem As Range
Dim lngRowNum As Long
Dim lngFindCol As Long
Dim lngFindRow As Long
Dim lngOver As Long
'デ−タの有るシートのデータを配列に取得
'デ−タの左上隅のセルを設定
If Not GetData(vntData, _
Worksheets("Sheet1").Cells(1, "A")) Then
Beep
MsgBox "データが有りません"
Exit Sub
End If
Application.ScreenUpdating = False
'表を作るシートに就いて
With Worksheets("Sheet2")
'シートをクリア
.Cells.Clear
'表の先頭（左上隅のセル）を設定
Set rngListTop = .Cells(1, "A")
End With
With rngListTop
'列項目の初期値
Set rngColItem = .Offset(, 1)
lngColNum = 1
'行項目の初期値
Set rngRowItem = .Offset(1)
lngRowNum = 1
'表に転記
For i = 1 To UBound(vntData, 1)
'Ａ列値の探索範囲の取得
Set rngScopeRow = rngRowItem.Resize(lngRowNum)
'Ａ列値の行位置を探索
lngFindRow = ItemSearch(vntData(i, 1), _
rngScopeRow, lngOver, 1)
'探索値が無かった場合（未発見）
If lngFindRow = 0 Then
'探索範囲行数を更新
lngRowNum = lngRowNum + 1
'挿入位置に行を挿入
With .Offset(lngOver)
.EntireRow.Insert
End With
'挿入行位置を発見行位置に設定
lngFindRow = lngOver
'行項目の初期値を再設定
Set rngRowItem = .Offset(1)
'挿入行位置にＡ列値を記入
With .Offset(lngFindRow)
.Value = vntData(i, 1)
End With
End If
'日付の範囲を設定
Set rngScopeCol = rngColItem.Resize(, lngColNum)
'日付を探索
lngFindCol = ItemSearch(CLng(vntData(i, 2)), _
rngScopeCol, lngOver, 1)
'日付が無かった場合（未発見）
If lngFindCol = 0 Then
'探索範囲列数を更新
lngColNum = lngColNum + 1
'挿入位置に列を挿入
With .Offset(, lngOver)
.EntireColumn.Insert
End With
'挿入位置を発見位置に設定
lngFindCol = lngOver
'列項目の初期値を再設定
Set rngColItem = .Offset(, 1)
'挿入列位置に日付を記入
With .Offset(, lngFindCol)
'日付を記入
.Value = CLng(vntData(i, 2))
End With
End If
'発見した行列に値を記入
With .Offset(lngFindRow, lngFindCol)
.Value = .Value + 1
End With
Next i
'書式を日付に設定
rngScopeCol.NumberFormat = "yyyy/mm/dd"
End With
Set rngScopeCol = Nothing
Set rngScopeRow = Nothing
Set rngListTop = Nothing
Set rngColItem = Nothing
Set rngRowItem = Nothing
Application.ScreenUpdating = True
Beep
MsgBox "処理が完了しました"
End Sub
Private Function GetData(vntData As Variant, _
rngDataTop As Range) As Boolean
Dim rngScope As Range
Set rngScope = rngDataTop.CurrentRegion
With rngScope
'もし、データが有る場合
If .Columns.Count >= 1 And .Rows.Count >= 1 Then
'wksDataのデータを配列に取得
vntData = .Value
'データ取得成功を戻す
GetData = True
End If
End With
Set rngScope = Nothing
End Function
Private Function ItemSearch(vntKey As Variant, _
rngScope As Range, _
Optional lngOver As Long, _
Optional lngCollation As Long = 1) As Long
Dim vntFind As Variant
Dim lngDataTop As Long
If rngScope Is Nothing Then
lngOver = 1
Exit Function
End If
'Matchによる二分探索
vntFind = Application.Match(vntKey, rngScope, lngCollation)
'もし、エラーで無いなら
If Not IsError(vntFind) Then
'もし、Key値と探索位置の値が等しいなら
If vntKey = rngScope.Cells(vntFind).Value Then
'戻り値として、位置を代入
ItemSearch = vntFind
End If
'Key値を超える最小値のある行
lngOver = vntFind + 1
Else
lngOver = 1
End If
End Function
|
|
Hirofumi
- 04/8/15(日) 20:26 -
