Excel VBA質問箱 IV

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

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


43821 / 76732 ←次へ | 前へ→

【37938】Re:条件判定について
回答  Hirofumi  - 06/5/23(火) 19:43 -

引用なし
パスワード
   結果の表は、其のままでも出来ますが?
色々面倒なので、以下の様な表なら簡単に(多分?)出来ると思います
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
0 hits

【37931】条件判定について あい 06/5/23(火) 16:42 質問
【37936】Re:条件判定について ichinose 06/5/23(火) 19:28 発言
【37957】Re:条件判定について あい 06/5/24(水) 10:46 お礼
【37938】Re:条件判定について Hirofumi 06/5/23(火) 19:43 回答
【37958】Re:条件判定について あい 06/5/24(水) 10:47 お礼

43821 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free