| |
もう見て居ないかな？
Sheet1に以下の様なデータが有るとします
A B
1 コード 値段
2 20 710
3 37 785
4 36 527
5 29 521
6 83 394
7 79 561
8 30 493
9 ・ ・
10 ・ ・
Sheet2に以下の様な集計表が有るとします
A B
1 以上 合計
2 1
3 11
4 21
5 31
6 41
7 51
8 61
9 71
10 81
11 91
以下のコードを実行すると、
集計表のB2には、1以上11未満のコードに対する、値段の合計が入ります
同様に、B3には、11以上21未満のコードに対する、値段の合計が入ります
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
'結果出力基準位置を設定
Set rngResult = Worksheets("Sheet2").Cells(1, "B")
'集計コードの階級表に位置を配列に取得
With rngResult.Offset(, -1)
'データ行数を取得
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
'データListの左上隅セル位置を基準として設定(列見出し「コード」のセル位置)
Set rngList = Worksheets("Sheet1").Cells(1, "A")
With rngList
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
'データが無い場合
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
End With
'集計表を作成
'データListの最終行まで繰り返し
For i = 1 To lngRows
'1行分データを配列に取得
vntData = rngList.Offset(i).Resize(, 2).Value
'コードがどの階級に属するか探索
lngFound = BinarySearch(vntData(1, 1), vntMark, lngUnder)
'そのコード其の物の値が無い場合
If lngFound < 0 Then
'そのコードの値を、超えない最大値の行を指定
lngFound = lngUnder
End If
'指定行に値段を加算
vntResult(lngFound, 1) = vntResult(lngFound, 1) + vntData(1, 2)
Next i
'画面更新を停止
' Application.ScreenUpdating = False
With rngResult
'集計結果を出力
.Offset(1).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}
- 06/4/1(土) 17:52 -
