Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

45241 / 76732

←次へ　｜　前へ→


	【36492】Re:コードによる集計をＶＢＡで行う方法

Hirofumi - 06/4/1(土) 21:17 -


	引用なし

	パスワード

もう見て居ないかな？

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

6 hits

▼

【36485】コードによる集計をＶＢＡで行う方法 mero 06/4/1(土) 17:03