Excel VBA質問箱 IV

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

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


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

40149 / 76732

←次へ　｜　前へ→


	【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と表示する場合)
　　　　　　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

1 hits

▼

【41674】時間の重なり分を除いた日ごとの合計を別シートに当てはめたい みなみ 06/8/19(土) 12:34