| |
全てコードで行うとこんな？
Option Explicit
Public Sub AddUp()
Dim i As Long
Dim lngFindCol As Long
Dim lngFindRow As Long
Dim vntData As Variant
Dim lngOver As Long
Dim lngColNum As Long
Dim lngRowNum As Long
Dim rngScopeCol As Range
Dim rngScopeRow As Range
Dim rngListTop As Range
Dim rngColItem As Range
Dim rngRowItem As Range
'デ−タの有るシートのデータを配列に取得
'GetDataの第１引数：データを取得する配列
' 第2引数：データの左上隅
If GetData(vntData, Worksheets("Sheet1").Cells(1, "A")) = 0 Then
Beep
MsgBox "データが有りません"
Exit Sub
End If
Application.ScreenUpdating = False
'表を作るシートの先頭セルを設定
Set rngListTop = Worksheets("Sheet2").Cells(1, "A")
'表を作るシートをクリア
rngListTop.Parent.Cells.Clear
'列項目の初期値
Set rngColItem = rngListTop.Offset(, 1)
'行項目の初期値
Set rngRowItem = rngListTop.Offset(1)
'初期値設定
With rngColItem
'日付を記入
'データに列見出しが無い場合
'（有る場合は、vntData(2, 1)）
.Value = vntData(1, 1)
'日付行の初期列設定
lngColNum = 1
End With
With rngRowItem
'Itemを記入
'データに列見出しが無い場合
'（有る場合は、vntData(2, 2)）
.Value = vntData(1, 2)
'Item列の初期行設定
lngRowNum = 1
End With
'データに列見出しが無い場合
'（有る場合は、vntData(2, 3)）
rngListTop.Offset(lngRowNum, lngColNum).Value _
= Val(StrConv(vntData(1, 3), vbNarrow))
'表に転記
With rngListTop
'データに列見出しが無い場合
'（有る場合は、i = 3から）
For i = 2 To UBound(vntData, 1)
'Itemの探索範囲の取得
Set rngScopeRow = rngRowItem.Resize(lngRowNum)
'Itemの行位置を探索
lngFindRow = ItemSearch(vntData(i, 2), _
rngScopeRow, lngOver, 0)
'探索値が無かった場合（未発見）
If lngFindRow = 0 Then
'探索範囲行数を更新
lngRowNum = lngRowNum + 1
'最終行にItemを記入
.Offset(lngRowNum).Value _
= vntData(i, 2)
'最終行の下を発見位置に設定
lngFindRow = lngRowNum
End If
'日付の範囲を設定
Set rngScopeCol = rngColItem.Resize(, lngColNum)
'日付を探索
lngFindCol = ItemSearch(CLng(vntData(i, 1)), _
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 = vntData(i, 1)
End With
End If
'発見した行列に値を記入
.Offset(lngFindRow, lngFindCol).Value _
= .Offset(lngFindRow, lngFindCol).Value _
+ Val(StrConv(vntData(i, 3), vbNarrow))
Next i
End With
'日付を"m/d"形式に書式設定
With rngScopeCol
.Resize(, lngColNum).NumberFormatLocal = "m/d"
End With
Set rngScopeCol = Nothing
Set rngScopeRow = Nothing
Application.ScreenUpdating = True
Beep
MsgBox "処理が完了しました"
End Sub
Private Function GetData(vntData As Variant, _
rngData As Range) As Long
Dim rngScope As Range
'データの左上隅を基準としてデータ範囲を取得
Set rngScope = rngData.CurrentRegion
With rngScope
'rngScopeのデータを配列に取得
vntData = .Value
'データが無い場合
If vntData(1, 1) = "" Then
GetData = 0
Else
'データの最終行を取得
GetData = .Rows.Count
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/11/3(水) 10:49 -
