| |
日付が昇順にソートされている事が前提として
以下を標準モジュールに記述して下さい
Option Explicit
Public Sub AddUp()
'材料数 - 1
Const lngKinds As Long = 2
'材料１の列位置
Const lngMat As Long = 3
Dim i As Long
Dim j As Long
Dim vntData As Variant
Dim lngEnd As Long
Dim vntResult() As Variant
Dim lngPos() As Long
Dim lngCol As Long
'結果用変数、書き込みポインッタを配列として確保
ReDim vntResult((lngKinds + 1) * 2 - 1, 0), _
lngPos(lngKinds)
'Sheet1のデータを配列に取得
With Worksheets("Sheet1")
lngEnd = .Cells(65536, "A").End(xlUp).Row
If lngEnd < 2 Then
Beep
MsgBox "データが有りません"
Exit Sub
End If
vntData = Range(.Cells(1, "A"), _
.Cells(lngEnd, "E")).Value
End With
'結果配列に列見出しを取得
For i = 0 To lngKinds
vntResult(i * 2, 0) = vntData(1, 1) '日付
vntResult(i * 2 + 1, 0) _
= vntData(1, i + lngMat) '材料
lngPos(i) = 0 '書き込みポインッタの初期値
Next i
'集計
'データの先頭から終りまで繰り返し
For i = 2 To UBound(vntData, 1)
'材料１、２、３に就いて繰り返し
For j = 0 To lngKinds
'書き込列を敬さん
lngCol = j * 2
'もし、日付が書き込み行の日付と違うなら
If vntData(i, 1) _
<> vntResult(lngCol, lngPos(j)) Then
'もし、データが0を超えるなら
If vntData(i, j + lngMat) > 0 Then
'書き込み行を更新
lngPos(j) = lngPos(j) + 1
'もし、結果配列の大きさがより
'書き込み位置が後なら
If UBound(vntResult, 2) _
< lngPos(j) Then
'結果配列を拡張
ReDim Preserve _
vntResult((lngKinds + 1) * 2 _
- 1, lngPos(j))
End If
'日付を代入
vntResult(lngCol, lngPos(j)) _
= vntData(i, 1)
'値を代入
vntResult(lngCol + 1, lngPos(j)) _
= vntData(i, j + lngMat)
End If
Else
'値を加算
vntResult(lngCol + 1, lngPos(j)) _
= vntResult(lngCol + 1, lngPos(j)) _
+ vntData(i, j + lngMat)
End If
Next j
Next i
'結果配列の行列を入れ替えて出力
With Worksheets("Sheet2")
.Cells(1, "A").Resize(UBound(vntResult, 2) + 1, _
UBound(vntResult, 1) + 1).Value _
= Application.Transpose(vntResult)
End With
Beep
MsgBox "処理が完了しました"
End Sub
|
|
Hirofumi
- 04/3/28(日) 2:37 -
