| |
▼Hirofumi さん：
>もう見て居ないかな？
>
>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
もう一度みてすごく良かったです。
こんなに、詳しくまたご親切にご教示いただき感謝いたします。
ExcelVBAの初心者ですので実際に要求されるものをどのように組み立ててよいか
理解できない点がありました。
大変参考になります。
貴重なお時間を割いてくださり誠に感謝にたえません。
|
|
mero
- 06/4/1(土) 21:55 -
