| |
>早速確認しましたところ、日付データが増えていっても動作しましたが、
>材料数が増えていった場合、うまく抽出しませんでした。
ゴメン
>のデータ(日付も、材料数も増え続けます）
を忘れていました
最終列位置を自動で取得する様にしました
以下の様にコードを変更して下さい
Option Explicit
Public Sub AddUp()
'材料１の列位置
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
Dim lngKinds As Long '★この行追加
'Sheet1のデータを配列に取得
With Worksheets("Sheet1")
'★以下の１０行追加
lngKinds = .Cells(1, _
"IV").End(xlToLeft).Column
If lngKinds < lngMat Then
Beep
MsgBox "データが有りません"
Exit Sub
End If
lngKinds = lngKinds - lngMat
'結果用変数、書き込みポインタを配列として確保
ReDim vntResult((lngKinds + 1) * 2 - 1, 0)
ReDim lngPos(lngKinds)
lngEnd = .Cells(65536, "A").End(xlUp).Row
If lngEnd < 2 Then
Beep
MsgBox "データが有りません"
Exit Sub
End If
vntData = Range(.Cells(1, "A"), _
.Cells(lngEnd, _
lngMat + lngKinds)).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(日) 7:21 -
