| |
此れで、集計出きると思います？
ただし
>15時を基準にして0:00から14:59までならば8/2とみなす、
>つまり、1日を0:00〜0:00の２４時間ではなく、15:00〜15:00の２４時間としたいんです。
この様な計算方法は取っていません（計算が縺れそうだし？）
データの補正で対応しています
Option Explicit
Public Sub Sample2()
'データ列数
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 vntResult As Variant
Dim lngTop As Long
Dim lngCount As Long
Dim strProm As String
'Listの左上隅セル位置を基準として設定
Set rngList = Worksheets("Sheet1").Cells(1, "A")
'出力先の先頭セル位置を出力基準とします
Set rngResult = Worksheets("Sheet2").Cells(1, "B")
With rngList
'データ行数を取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
'データが無い場合
If lngRows <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
'データを配列に取得
vntData = .Resize(lngRows + 1, clngColumns).Value
End With
'結果出力用配列を確保
ReDim vntResult(1 To 31, 1 To 1)
'先頭データを初期値とする
lngTop = 1
lngCount = 1
'データ2行目〜最終行+1まで繰り返し
For i = 2 To lngRows + 1
'日付が替わった場合
If vntData(lngTop, 1) <> vntData(i, 1) Then
'1日分の時間を計算(シリアル値の場合)
' vntResult(vntData(lngTop, 1), 1) _
= DayTimes(vntData, lngTop, lngTop + lngCount - 1)
'1日分の時間を計算(７０分なら70と表示する場合)
vntResult(vntData(lngTop, 1), 1) _
= Int(DayTimes(vntData, lngTop, _
lngTop + lngCount - 1) * 24 * 60 + 0.5)
'この行を先頭に
lngTop = i
'カウントを初期値に
lngCount = 1
Else
'カウントを更新
lngCount = lngCount + 1
End If
Next i
'画面更新を停止
Application.ScreenUpdating = False
'結果を出力
With rngResult.Resize(UBound(vntResult, 1))
'セル書式設定(シリアル値の場合)
' .NumberFormat = "[mm]"
.Value = vntResult
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function DayTimes(vntData As Variant, _
lngTop As Long, _
lngEnd As Long) As Double
'集計配列の行数
Const clngRowsCount As Long = 3
Dim i As Long
Dim j As Long
Dim vntResult As Variant
'データの補正(ブロック先頭開始より各時刻が小さい場合、翌日の時間とする)
'ブロック先頭開始よりブロック先頭終了時刻が小さい場合、翌日の時間とする
If vntData(lngTop, 2) > vntData(lngTop, 3) Then
vntData(lngTop, 3) = vntData(lngTop, 3) + 1
End If
'ブロック全てに就いて繰り返し
For i = lngTop + 1 To lngEnd
'ブロック先頭開始より現在行開始時刻が小さい場合、翌日の時間とする
If vntData(lngTop, 2) > vntData(i, 2) Then
vntData(i, 2) = vntData(i, 2) + 1
End If
'開始より頭終了時刻が小さい場合、翌日の時間とする
If vntData(i, 2) > vntData(i, 3) Then
vntData(i, 3) = vntData(i, 3) + 1
End If
Next i
'時間の重なりを除去したデータの配列を作成
'1日の集計配列ブロック数
j = 1
'集計用配列を確保
ReDim vntResult(1 To clngRowsCount, 1 To j)
'初期値を集計用配列に代入
vntResult(1, j) = vntData(lngTop, 2)
vntResult(2, j) = vntData(lngTop, 3)
'2ブロック目〜最終ブロックまで繰り返し
For i = lngTop + 1 To lngEnd
'データ配列の開始が、集計配列の終了より大きい場合(重なりが無い場合)
If vntData(i, 2) > vntResult(2, j) Then
'集計配列のブロック数を拡張
j = j + 1
ReDim Preserve vntResult(1 To clngRowsCount, 1 To j)
'集計配列の開始にデータ配列の開始時間を代入
vntResult(1, j) = vntData(i, 2)
'集計配列の終了にデータ配列の終了時間を代入
vntResult(2, j) = vntData(i, 3)
Else
'集計配列の開始よりデータ配列の開始が大きい場合
If vntResult(1, j) <= vntData(i, 2) Then
'集計配列の終了よりデータ配列の終了が大きい場合(重なりが有る場合)
If vntResult(2, j) < vntData(i, 3) Then
'集計配列の終了にデータ配列の終了を代入
vntResult(2, j) = vntData(i, 3)
End If
End If
End If
Next i
'1日の時間(分)を集計
j = j + 1
ReDim Preserve vntResult(1 To clngRowsCount, 1 To j)
For i = 1 To j - 1
vntResult(3, i) = vntResult(2, i) - vntResult(1, i)
vntResult(3, j) = vntResult(3, j) + vntResult(3, i)
Next i
DayTimes = vntResult(3, j)
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
