Excel VBA質問箱 IV

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

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


7025 / 13644 ツリー ←次へ | 前へ→

【41674】時間の重なり分を除いた日ごとの合計を別シートに当てはめたい みなみ 06/8/19(土) 12:34 質問[未読]
【41677】Re:時間の重なり分を除いた日ごとの合計... 飛ばない豚 06/8/19(土) 15:16 回答[未読]
【41678】Re:時間の重なり分を除いた日ごとの合計を... [名前なし] 06/8/19(土) 16:15 発言[未読]
【41679】Re:時間の重なり分を除いた日ごとの合計... 飛ばない豚 06/8/19(土) 16:41 回答[未読]
【41680】Re:時間の重なり分を除いた日ごとの合計を... みなみ 06/8/19(土) 17:17 発言[未読]
【41684】Re:時間の重なり分を除いた日ごとの合計を... Hirofumi 06/8/20(日) 1:44 回答[未読]
【41690】Re:時間の重なり分を除いた日ごとの合計を... みなみ 06/8/20(日) 8:52 お礼[未読]

【41674】時間の重なり分を除いた日ごとの合計を別...
質問  みなみ  - 06/8/19(土) 12:34 -

引用なし
パスワード
   こんにちは。
[#41472]で別のシートに合計を当てはめたいという質問をさせて頂きました、みなみです。

かみちゃんさんのご回答で見事に解決して頂き、早速使用していたのですが、
私の使用状況では労働時間帯が重なってしまう事がありました。

"シート1"でA列を日付、B列を時間1、C列を時間2として、その月の労働時間を入力します。
  A  B   C   
1 2 10:00 10:30   (30)
2 2 10:00 11:00   (60)
3 2 10:40 11:10   (30)
4 4 13:20 13:50   (30)
5 4 14:00 14:30   (30)
6 4 23:00  0:10   (70)
7 6  9:00  9:50   (50)
8 6  9:30 10:10   (40)
 
ここで問題になるのが1・2・3行目の2日の合計が
10:00〜11:10なので70分になって欲しいのですが、ご教授頂いたvbaですと
1・2行目の全ての合計を足すので120分になってしまいます。

同様に7・8行目の6日の合計も9:00〜10:10なので70分で計算したいのです。

そして、その結果を下記のようなA列に日付を書いた同一ブックの"シート2"のB列に入力したいのです。

  A  B      
1 1日 
2 2日 
3 3日 
4 4日 
5 5日 
6 6日 


質問ばかりで申し訳ありません。どうかご教授いただけませんでしょうか。
よろしくお願い致します。


尚、同じような質問が04/5/1に[#13332]の時間帯の重なり除去で
sこーさんが質問されており、
[#13404]のHirofumiさんが回答されておられました。

自分なりに考えてみて、時間順にソートして2行目のAが1行目のBより大きければ重なり無しとみなし、小さければ2行目のAが1行目のAより大きくて、2行目のBが1行目のBより大きければBの値を上書きしていくという理屈はようやくわかったのですが、理解してもそれを、この式をお手本にして今回の件に生かす力がございません・・・・。

本当に申し訳ありません。

【41677】Re:時間の重なり分を除いた日ごとの合計...
回答  飛ばない豚  - 06/8/19(土) 15:16 -

引用なし
パスワード
   ▼みなみ さん:
1日分の数直線に見立てた変数(mySCALE)を用意し、
該当のところを塗りつぶす(1を立てる)ようにし、
その数を数えてみました。

リンク先はよく見てませんが、似たような考えだと思います(多分)

Sub sub_時間計算()
  Dim mySCALE(1 To 1440) As Integer
  Dim myCALC(1 To 31) As Long
  Dim myTimeS As Date
  Dim myTimeE As Date
  Dim myRange As Range
  Dim myLastR As Range
  Dim myDay As Long
  Dim myLooP As Long
  
  Sheets("Sheet1").Activate
  Set myLastR = Cells(Cells.Rows.Count, 1).End(xlUp)
  
  For myDay = 1 To 31
    Erase mySCALE
    For Each myRange In Range("A1", myLastR)
      If myRange.Value = myDay Then
        myTimeS = myRange.Offset(0, 1).Value
        myTimeE = myRange.Offset(0, 2).Value
        If myTimeS > myTimeE Then
          For myLooP = 1 To Hour(myTimeE) * 60 _
                   + Minute(myTimeE) - 1
            mySCALE(myLooP) = 1
          Next myLooP
          For myLooP = Hour(myTimeS) * 60 _
                 + Minute(myTimeS) To 1440
            mySCALE(myLooP) = 1
          Next myLooP
        Else
          For myLooP = Hour(myTimeS) * 60 + Minute(myTimeS) _
              To Hour(myTimeE) * 60 + Minute(myTimeE) - 1
            mySCALE(myLooP) = 1
          Next myLooP
        End If
      End If
    Next myRange
    
    For myLooP = 1 To 1440
      myCALC(myDay) = myCALC(myDay) + mySCALE(myLooP)
    Next myLooP
  Next myDay
  
  Sheets("Sheet2").Range("B1").Resize(UBound(myCALC)).Value = _
                    Application.Transpose(myCALC)
  
End Sub


それでは。(^・ω・^)

【41678】Re:時間の重なり分を除いた日ごとの合計...
発言  [名前なし]  - 06/8/19(土) 16:15 -

引用なし
パスワード
   [#41483]のかみちゃんさんのコードを元に、

>時間順にソートして2行目のAが1行目のBより大きければ重なり無しとみなし、
>小さければ2行目のAが1行目のAより大きくて、2行目のBが1行目のBより
>大きければBの値を上書きしていく

というコードにしてみました。

Sub Macro1()
  Dim LastCell As Range
  Dim c As Range
  '日別集計用の変数31要素
  Dim vntData(1 To 31) As Long 'ちょっと変更
  Dim DayNum As Long, TimeS As Date, TimeL As Date '追加
  Dim TimeS1 As Date, TimeL1 As Date '追加
  
  Sheets("Sheet1").Activate
  
  '日→時間1→時間2の順で並べ替え
  Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Key2:=Range("B1"), _
  Key3:=Range("B3"), Header:=xlNo
  
  Set LastCell = Cells(Cells.Rows.Count, 1).End(xlUp)
  DayNum = 0
  For Each c In Range("A1", LastCell)
    '以下変更
    TimeS1 = c.Offset(, 1).Value '時間1を取得
    TimeL1 = c.Offset(, 2).Value '時間2を取得
    
    If TimeS1 > TimeL1 Then TimeL1 = TimeL1 + 1   '24時をまたがる場合
      
    If Val(c.Value) = DayNum Then '日が同じ場合
     '保存している時間2と比較して、時間2が小さい場合
     '→計算済みの時間と完全に重複しているので、DateDiffの結果を0にする
      If TimeL > TimeL1 Then
        TimeS = TimeL
      Else
        TimeS = TimeS1
       '保存している時間2と比較して、時間1のほうが小さい場合
       '→重複している時間を除く
        If TimeS < TimeL Then TimeS = TimeL
        TimeL = TimeL1
      End If
    Else '日が変わった場合
      TimeS = TimeS1
      TimeL = TimeL1
    End If
    
    '配列に結果を計算
    vntData(Val(c.Value)) = vntData(Val(c.Value)) + DateDiff("n", TimeS, TimeL)
    
    DayNum = Val(c.Value) '日を保存
  
  '-- ※1 D列に時間(分)を出力する部分(不要なら削除)
    c.Offset(, 3).Value = DateDiff("n", TimeS1, TimeL1) 'D列に出力
'--------------------------------------------------------------------------
  '-- ※2 E,F列に実際に計算に使う時刻を出力する部分(不要なら削除)
    With WorksheetFunction
      c.Offset(, 4).Value = .Text(TimeS, "[hh]:mm:ss") 'E列に出力
      c.Offset(, 5).Value = .Text(TimeL, "[hh]:mm:ss") 'F列に出力
    End With
'--------------------------------------------------------------------------
  
  Next
  Sheets("Sheet2").Range("B1").Resize(UBound(vntData)).Value = _
  Application.Transpose(vntData)
  
  MsgBox "集計完了"
End Sub

一応、下記のようなデータで確かめました。

   A    B
2  10:00  10:30
2  10:00  11:00
2  10:40  11:10
4  13:20  13:50
4  14:00  14:30
4  23:00  0:10
6  9:00  9:50
6  9:30  10:10
7  9:30  10:50
7  10:00  10:40
7  10:20  10:50
7  10:30  11:00
8  23:00  0:30
8  23:20  0:10
8  23:50  1:00
9  0:00  0:30
9  23:00  0:00
9  23:30  0:50

【41679】Re:時間の重なり分を除いた日ごとの合計...
回答  飛ばない豚  - 06/8/19(土) 16:41 -

引用なし
パスワード
   [名前なし]さんのデータをテストしてみたら、0:00のところでエラーが
発生してしまいました。
ということで、mySCALE(1 to 1440)を、0 to 1439に修正しました。

Sub sub_時間計算()
  Dim mySCALE(1439) As Integer
  Dim myCALC(1 To 31) As Long
  Dim myTimeS As Date
  Dim myTimeE As Date
  Dim myRange As Range
  Dim myLastR As Range
  Dim myDay As Long
  Dim myLooP As Long
  
  Sheets("Sheet1").Activate
  Set myLastR = Cells(Cells.Rows.Count, 1).End(xlUp)
  
  For myDay = 1 To 31
    Erase mySCALE
    For Each myRange In Range("A1", myLastR)
      If myRange.Value = myDay Then
        myTimeS = myRange.Offset(0, 1).Value
        myTimeE = myRange.Offset(0, 2).Value
        If myTimeS > myTimeE Then
          For myLooP = 0 To Hour(myTimeE) * 60 _
                   + Minute(myTimeE) - 1
            mySCALE(myLooP) = 1
          Next myLooP
          For myLooP = Hour(myTimeS) * 60 _
                 + Minute(myTimeS) To 1439
            mySCALE(myLooP) = 1
          Next myLooP
        Else
          For myLooP = Hour(myTimeS) * 60 + Minute(myTimeS) _
              To Hour(myTimeE) * 60 + Minute(myTimeE) - 1
            mySCALE(myLooP) = 1
          Next myLooP
        End If
      End If
    Next myRange
    
    For myLooP = 0 To 1439
      myCALC(myDay) = myCALC(myDay) + mySCALE(myLooP)
    Next myLooP
  Next myDay
  
  Sheets("Sheet2").Range("B1").Resize(UBound(myCALC)).Value = _
                    Application.Transpose(myCALC)
  
End Sub


まだまだですね。(^・ω・^)

【41680】Re:時間の重なり分を除いた日ごとの合計...
発言  みなみ  - 06/8/19(土) 17:17 -

引用なし
パスワード
   ▼飛ばない豚さん、名前なしさん

早々にご回答頂きありがとうございます。
みなさんの知識に感動するばかりです。

今見させて頂いていますが、前回同様にまだまだ全体を把握するのに
時間が掛かります・・・。

まずはお礼を言わせて頂きます。
ありがとうございます。

判らない事があればご質問させてください。
宜しくお願いいたします。

【41684】Re:時間の重なり分を除いた日ごとの合計...
回答  Hirofumi  - 06/8/20(日) 1:44 -

引用なし
パスワード
   遅れ馳せながら?
こんなかな?

データは必ずB列がC列より小さい物とします
データは、既に並べ替えられている物とします
データA列の日付は、整数で有る物とする(例として「1」、「3」・・)

Option Explicit

Public Sub Sample()

  'データ列数
  Const clngColumns As Long = 3
  
  Dim i As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim vntData As Variant
  Dim rngResult As Range
  Dim vntResult As Variant
  Dim lngTop As Long
  Dim lngCount As Long
  Dim strProm As String
  
  'Listの左上隅セル位置を基準として設定
  Set rngList = Worksheets("Sheet1").Cells(1, "A")
  
  '出力先の先頭セル位置を出力基準とします
  Set rngResult = Worksheets("Sheet2").Cells(1, "B")
  
  With rngList
    'データ行数を取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
    'データが無い場合
    If lngRows <= 1 And .Value = "" Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'データを配列に取得
    vntData = .Resize(lngRows + 1, clngColumns).Value
  End With
  'データの補正(開始より終了が小さい場合翌、日の時間とする)
  For i = 1 To lngRows
    If vntData(i, 2) > vntData(i, 3) Then
      vntData(i, 3) = vntData(i, 3) + 1
    End If
  Next i
  
  '結果出力用配列を確保
  ReDim vntResult(1 To 31, 1 To 1)
  
  '先頭データを初期値とする
  lngTop = 1
  lngCount = 1
  'データ2行目〜最終行+1まで繰り返し
  For i = 2 To lngRows + 1
    '日付が替わった場合
    If vntData(lngTop, 1) <> vntData(i, 1) Then
      '1日分の時間を計算(シリアル値の場合)
'      vntResult(vntData(lngTop, 1), 1) _
          = DayTimes(vntData, lngTop, lngTop + lngCount - 1)
      '1日分の時間を計算(70分なら70と表示する場合)
      vntResult(vntData(lngTop, 1), 1) _
          = Int(DayTimes(vntData, lngTop, _
              lngTop + lngCount - 1) * 24 * 60 + 0.5)
      'この行を先頭に
      lngTop = i
      'カウントを初期値に
      lngCount = 1
    Else
      'カウントを更新
      lngCount = lngCount + 1
    End If
  Next i
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '結果を出力
  With rngResult.Resize(UBound(vntResult, 1))
    'セル書式設定(シリアル値の場合)
'    .NumberFormat = "[mm]"
    .Value = vntResult
  End With
  
  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Private Function DayTimes(vntData As Variant, _
              lngTop As Long, _
              lngEnd As Long) As Double

  '集計配列の行数
  Const clngRowsCount As Long = 3
  
  Dim i As Long
  Dim j As Long
  Dim vntResult As Variant
  
  '時間の重なりを除去したデータの配列を作成
  '1日の集計配列ブロック数
  j = 1
  '集計用配列を確保
  ReDim vntResult(1 To clngRowsCount, 1 To j)
  '初期値を集計用配列に代入
  vntResult(1, j) = vntData(lngTop, 2)
  vntResult(2, j) = vntData(lngTop, 3)
  '2ブロック目〜最終ブロックまで繰り返し
  For i = lngTop + 1 To lngEnd
    'データ配列の開始が、集計配列の終了より大きい場合(重なりが無い場合)
    If vntData(i, 2) > vntResult(2, j) Then
      '集計配列のブロック数を拡張
      j = j + 1
      ReDim Preserve vntResult(1 To clngRowsCount, 1 To j)
      '集計配列の開始にデータ配列の開始時間を代入
      vntResult(1, j) = vntData(i, 2)
      '集計配列の終了にデータ配列の終了時間を代入
      vntResult(2, j) = vntData(i, 3)
    Else
      '集計配列の開始よりデータ配列の開始が大きい場合
      If vntResult(1, j) <= vntData(i, 2) Then
        '集計配列の終了よりデータ配列の終了が大きい場合(重なりが有る場合)
        If vntResult(2, j) < vntData(i, 3) Then
          '集計配列の終了にデータ配列の終了を代入
          vntResult(2, j) = vntData(i, 3)
        End If
      End If
    End If
  Next i
  
  '1日の時間(分)を集計
  j = j + 1
  ReDim Preserve vntResult(1 To clngRowsCount, 1 To j)
  For i = 1 To j - 1
    vntResult(3, i) = vntResult(2, i) - vntResult(1, i)
    vntResult(3, j) = vntResult(3, j) + vntResult(3, i)
  Next i
  
  DayTimes = vntResult(3, j)
  
End Function

【41690】Re:時間の重なり分を除いた日ごとの合計...
お礼  みなみ  - 06/8/20(日) 8:52 -

引用なし
パスワード
   ▼飛ばない豚さん、名前なしさん、Hirofumiさん


14時間もかかってしまいましたが、全てのコードを一つずつ確認させて頂きました。

求める所は同じなのに、いろいろなやり方があるんだな〜、とほんと関心しました。
そして、知らない世界が少しずつ開けてくる事が楽しかったです。

私も皆さんに少しでも近づけるように頑張りたいです。

皆さん、本当にありがとうございました。

Hirofumiさん、2年も遡ってご回答頂けたことに本当に感謝します。

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