| |
結果の表は、其のままでも出来ますが？
色々面倒なので、以下の様な表なら簡単に（多分？）出来ると思います
A列の値は、シリアル値に成るようにして下さい（文字列は不可）
A列の値を基準に集計します
また、2時間置きなら、A列を、0:00、2:00、・・として下さい
尚、C列の値は、未満と言う意味です（例、1:00は、0:59:59.・・・）
Sheet2の結果表
A列 B列 C列 D列
1 時間帯 売上
2 0:00 〜 1:00
3 1:00 〜 2:00
4 2:00 〜 3:00
5 3:00 〜 4:00
6 4:00 〜 5:00
7 5:00 〜 6:00
8 6:00 〜 7:00
9 7:00 〜 8:00
10 8:00 〜 9:00
11 9:00 〜 10:00 \2,400
12 10:00 〜 11:00
13 11:00 〜 12:00
14 12:00 〜 13:00
15 13:00 〜 14:00
16 14:00 〜 15:00
17 15:00 〜 16:00
18 16:00 〜 17:00
19 17:00 〜 18:00 \800
20 18:00 〜 19:00
21 19:00 〜 20:00 \100
22 20:00 〜 21:00
23 21:00 〜 22:00
24 22:00 〜 23:00
25 23:00 〜
Option Explicit
Public Sub Sample()
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim vntData As Variant
Dim vntMark As Variant
Dim lngFound As Long
Dim lngUnder As Long
Dim rngResult As Range
Dim strProm As String
'データListの左上隅セル位置を基準として設定(列見出し「OFF時刻」のセル位置)
Set rngList = Worksheets("Sheet1").Cells(1, "E")
'結果出力基準位置を設定
Set rngResult = Worksheets("Sheet2").Cells(1, "A")
'「OFF時刻」の集計階級（集計時刻）を配列に取得
With rngResult
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
'データが無い場合
If lngRows <= 0 Then
strProm = "集計階級（集計時刻）表が有りません"
GoTo Wayout
End If
'集計階級（集計時刻）を配列に取得
vntMark = .Offset(1).Resize(lngRows).Value
'結果出力用配列を確保
ReDim vntResult(1 To lngRows, 1 To 1)
End With
With rngList
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
'データが無い場合
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'データを配列に取得(「OFF時刻」、「売上」の2列)
vntData = .Offset(1).Resize(lngRows, 2).Value
End With
'集計表を作成
'データListの最終行まで繰り返し
For i = 1 To lngRows
'「OFF時刻」がどの集計階級（集計時刻）に属するか探索
lngFound = BinarySearch(vntData(i, 1), vntMark, lngUnder)
'その「OFF時刻」其の物の値が無い場合
If lngFound < 0 Then
'その「OFF時刻」の値を、超えない最大値の行を指定
lngFound = lngUnder
End If
'指定行に「売上」を加算
vntResult(lngFound, 1) = vntResult(lngFound, 1) + vntData(i, 2)
Next i
'画面更新を停止
' Application.ScreenUpdating = False
With rngResult
'集計結果を出力
.Offset(1, 3).Resize(UBound(vntResult, 1)).Value = vntResult
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function BinarySearch(ByVal vntKey As Variant, _
ByVal vntScope As Variant, _
Optional lngUnder As Long = -1, _
Optional lngOver As Long = -1) As Long
' 二進探索
Dim lngLow As Long
Dim lngHigh As Long
Dim lngMiddle As Long
lngLow = LBound(vntScope, 1)
lngHigh = UBound(vntScope, 1)
Do Until lngLow > lngHigh
lngMiddle = (lngLow + lngHigh) \ 2
Select Case vntScope(lngMiddle, 1)
Case Is < vntKey
lngLow = lngMiddle + 1
Case Is > vntKey
lngHigh = lngMiddle - 1
Case Is = vntKey
lngLow = lngMiddle + 1
lngHigh = lngMiddle - 1
End Select
Loop
If lngLow = lngHigh + 2 Then
BinarySearch = lngMiddle
Else
BinarySearch = -1
End If
lngUnder = lngHigh
lngOver = lngLow
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
