[[20210127023505]] 『利用者のいない時間帯の割り出し方』(教えて下さい) >>BOT

[ 初めての方へ | 一覧(最新更新順) |

| 全文検索 | 過去ログ ]

 

『利用者のいない時間帯の割り出し方』(教えて下さい)

A列に日付、B列に利用開始時間、C列に利用終了時間が入っているデータがあるのですが、その中から営業時間の間で利用者のいない時間を分単位で日付毎に抽出することは出来ますでしょうか?

現状日付・時間帯毎の利用者数などは出せているのですが、利用されていない時間帯の絞り方がわからず困っています。

どうかご教授ください

< 使用 Excel:Excel2019、使用 OS:Windows10 >


いくつかインプットとアウトプットの例を
行番号列番号がわかる形で提示して下さい。

(γ) 2021/01/27(水) 05:38


そう難しいことは申し上げていないはずですが。
アウトプットは、
 開始     終了
 10:00    10:30
 11:00    11:10
のような形式でいいんですか?

それとも、

 10:00
 10:01
 ・・・
のような表に空きのマークを付けるとかなんですか?
「分単位で」というのは、単位のことだけ言っているのか、
表示形式のことを言っているのか不明なんですよ。

それはシートのどこに、どのようなレイアウトで示すんですか?
ということを確認しているんですが。
(γ) 2021/01/27(水) 21:19


返信が遅れてしまい申し訳ありません。
前者です。

開始 終了 日付
10:00 10:30 2021/1/27
11:00 11:10 2021/1/27
のような感じで1000件近いデータがあります。(利用可能時間は07:00〜15:00とします)
この表で行くと1/27は10:30〜11:00までの00:30が利用のなかった時間に該当します。
それを求めたいという事でした。
どうかよろしくお願いします。
(教えて下さい) 2021/01/28(木) 23:59


 以下のようなレイアウトとしました。

 <<Sheet1>> 元データ
    A         B           C
  1 利用日    開始時刻    終了時刻
  2 2021/1/27     9:00    10:00
  3 2021/1/27     9:50    10:30
  4 2021/1/27    10:32    10:40
  5 2021/1/27    11:00    11:30
  6 2021/1/27    11:40    12:00
  7 2021/1/27    12:10    12:30
  8 2021/1/27    12:10    12:50
  9 2021/1/27    13:00    13:10
 10 2021/1/27    13:20    13:40
 11 2021/1/27    13:50    14:00
 (時刻は順不同でかまいません)

 <<Sheet2>> 結果
    A          B         C
  1 日付       空き開始  空き終了
  2 2021/1/27    10:30   10:32
  3 2021/1/27    10:40   11:00
  4 2021/1/27    11:30   11:40
  5 2021/1/27    12:00   12:10
  6 2021/1/27    12:50   13:00
  7 2021/1/27    13:10   13:20
  8 2021/1/27    13:40   13:50
  9 2021/1/27    14:00   15:00
 (一行目の見出しは事前に入れておいてください)

 ●マクロは、以下に示しますが、事前に次の準備と、マクロの修正(必要なら)をして下さい。
 (1)作業用に「作業用」という名前のシートを使いますので、
    既にそうしたシートがもしあれば、名前を別のものに変更しておいてください。
 (2)マクロの中で■をつけたところに、二つのシート名、営業開始時刻、営業終了時刻などが
    設定してあります。実態に応じて、必要な修正をして下さい。

 ●マクロは以下です。
   ・標準モジュールにコピーし、   
   ・上記の修正をした後、
   ・マクロ main を実行して下さい。

 ===  次行以下をまるごとコピーして下さい。===
 Dim ws1 As Worksheet
 Dim ws2 As Worksheet
 Dim tool As Worksheet

 Dim 営業開始時刻 As Date
 Dim 営業終了時刻 As Date
 Dim 営業時間範囲 As Range
 Dim oneminute As Date
 Dim pos As Long            '結果書き込み先の行番号

 Sub main()
     Dim k      As Long
     Dim d      As Date
     Dim startR As Long
     Dim endR   As Long
     Dim startD As Date

     Application.ScreenUpdating = False
     Application.Calculation = xlCalculationManual

     Set ws1 = Worksheets("Sheet1")    '元データのシート       ■ 要修正
     Set ws2 = Worksheets("Sheet2")    '空き時間を書くシート   ■  要修正

     '定数値の設定
     営業開始時刻 = CDate("7:00")                '■ 必要に応じて修正
     営業終了時刻 = CDate("15:00")               '■ 必要に応じて修正
     oneminute = CDate("0:01")

     '作業領域の設定
     Call setting      ' 作業用シートの設定
     Set 営業時間範囲 = map(営業開始時刻, 営業終了時刻 - oneminute)
     ws2.Columns("A").NumberFormatLocal = "yyyy/m/d"
     ws2.Columns("B:C").NumberFormatLocal = "h:mm"

     '利用日ごとの処理
     pos = 2                     '結果の書き込み開始行番号
     startD = ws1.Cells(2, "A")  '利用日の初期値
     startR = 2                  '算定対象の開始行

     For k = 2 To ws1.Cells(Rows.Count, "A").End(xlUp).Row + 1
         '最後の日を処理するために +1 していることに注意
         d = ws1.Cells(k, "A")
         If d <> startD Then    '日にちが変わったら、1日の処理を実行
             endR = k - 1

             ' strtR行からendR行までを対象に空き時間を調査
             Call 利用なし期間の分析(startR, endR)  'ここが作業の中心

             startD = d      '次に向けた準備
             startR = k
         End If
     Next
     ws2.Activate

     Application.ScreenUpdating = True
     Application.Calculation = xlCalculationAutomatic

 End Sub

 'toolシートに作業用領域を設定
 Private Function setting()
     Dim ws   As Worksheet
     Dim flag As Boolean
     Dim k    As Long
     Dim t    As Double

     '作業用シートの有無を調べ、なければ追加
     For Each ws In Worksheets
         If ws.Name = "作業用" Then
             Set tool = ws
             flag = True: Exit For
         End If
     Next ws
     If flag = False Then
         Set tool = Worksheets.Add(after:=Worksheets(Worksheets.Count))
         tool.Name = "作業用"
     End If

     tool.Columns("A").NumberFormatLocal = "h:mm"
     tool.Columns("A").ClearContents

     '1分刻みの表を作成
     For t = 営業開始時刻 To 営業終了時刻 - oneminute Step oneminute
         k = k + 1
         tool.Cells(k, "A") = t
     Next
 End Function

 ' strtR行からendR行までの利用状況をもとに、空き時間を作成して書き込み
 Private Sub 利用なし期間の分析(startR As Long, endR As Long)
     Dim myUnion     As Range
     Dim diff_rng    As Range
     Dim tmp         As Range
     Dim area        As Range
     Dim k           As Long

     '使用時間帯の統合
     For k = startR To endR
         Set tmp = map(ws1.Cells(k, "B"), ws1.Cells(k, "C") - oneminute)
         If myUnion Is Nothing Then
             Set myUnion = tmp
         Else
             Set myUnion = Union(myUnion, tmp)
         End If
     Next

     '全体から、使用時間帯を除いた差集合を算出
     Set diff_rng = diff(営業時間範囲, myUnion)

     'ワークシートに書き込み
     For Each area In diff_rng.Areas
         ws2.Cells(pos, "A") = ws1.Cells(startR, "A")
         ws2.Cells(pos, "B") = area(1).Value
         ws2.Cells(pos, "C") = area(area.Count).Value + oneminute
         pos = pos + 1
     Next
 End Sub

 Private Function posOfTime(d As Date) As Long
     Dim v  As Double
     If d < 営業開始時刻 Then
         MsgBox "営業開始前"
         Exit Function
     End If
     posOfTime = (CDbl(d) - CDbl(営業開始時刻)) / CDbl(oneminute) + 1
 End Function

 '使用開始時間から使用終了時刻までを表す「セル範囲」を算定
 Private Function map(startTime As Date, endTime As Date) As Range
     Dim r1&, r2&
     r1 = posOfTime(startTime)
     r2 = posOfTime(endTime)
     Set map = tool.Range(tool.Cells(r1, "A"), tool.Cells(r2, "A"))
 End Function

 '差集合の算出(rngAのなかで、rngBを除いたセル範囲)
 Private Function diff(rngA As Range, rngB As Range) As Range
     Dim r As Range

     For Each r In rngA
         If Intersect(r, rngB) Is Nothing Then
             If diff Is Nothing Then
                 Set diff = r
             Else
                 Set diff = Union(diff, r)
             End If
         End If
     Next
 End Function

 ○マクロの中身には多分あまり興味ないと思いますが、若干の補足をしておきます。
   少しごてごてしていますが、考え方は以下のとおり。
 ・利用状態を 「作業用シートのA列」に1分単位で設定したセル範囲と対応づけ、
 ・先だって質問にあった、セル範囲の差集合を求めるロジックを使って、
   全体から利用済み期間を除く処理を行いました。
 ・動作確認は一応しましたが、エラー時の対応とか、余り、念入りに見ていません。

 ○速度的には改善の余地があると思いますが、そこそこの時間ですみます。
 100日×10件の1000件だと1.4秒程です。

 ○例えば、分単位の表を作り、利用済みのセルには 1を書き込み、
 空白セルをSpecialCellsで求め、各エリアから空き時間の開始・終了を読み取る、
 などといった手法はすぐに思いつきます。このほうが多分早いと思います。

 もっと斬新なアイデアが出てくるでしょうから楽しみにしています。

 なお、使用目的によりますが、セル範囲に色を使ってマークすることで、
 空き時間を視覚的に表示するのも有益じゃないかと思います。

(γ) 2021/01/29(金) 05:40


 >現状日付・時間帯毎の利用者数などは出せているのですが

まずチェックしたい時間全部の一覧表を用意すればいいのでは?
あと、日付と時間が別のセルにあると扱いにくいので、
仮にでも日付と時間を足して、1つのセルに日時を入れとくと、
CountIf関数で数えられそう?

ちなみに、関数で結果を求めるのですか?
マクロで結果を求めるのですか?
(まっつわん) 2021/01/29(金) 19:05


Sub main()
   Dim dt(), r As Range, rr As Range, x As Range, c As Range, cc As Range, ctr As Long
   For Each x In Range("C2:C" & Rows.Count).SpecialCells(2)
        If WorksheetFunction.CountIf(Range("C1:C" & x.Row), x.Value) = 1 Then
            For Each c In Range("A:A").SpecialCells(2)
              If c.Offset(, 2).Value = x.Value Then
                    Set cc = Range(Range("A" & Hour(c.Value) * 60 + Minute(c.Value)), Range("A" & Hour(c.Offset(, 1).Value) * 60 + Minute(c.Offset(, 1).Value)))
                    If r Is Nothing Then
                      Set r = cc
                    Else
                      Set r = Union(r, cc)
                    End If
               End If
            Next c
            For Each c In Range("A420:A900")
            If Intersect(r, c) Is Nothing Then
                If rr Is Nothing Then
                  Set rr = c
                Else
                  Set rr = Union(rr, c)
                End If
            End If
            Next c
            For Each c In rr.Areas
                ReDim Preserve dt(1, ctr)
                dt(0, ctr) = Int(c.Cells(1).Row / 60) & ":" & Format(c.Cells(1).Row - Int(c.Cells(1).Row / 60) * 60, "00") & "〜" & Int(c.Cells(c.Count).Row / 60) & ":" & Format(c.Cells(c.Count).Row - Int(c.Cells(c.Count).Row / 60) * 60, "00")
                dt(1, ctr) = Format(x.Value, "yyyy/m/d")
                ctr = ctr + 1
            Next c
        Set r = Nothing
        Set rr = Nothing
      End If
   Next x
    Sheets.Add after:=ActiveSheet
    Range("A1:B" & ctr) = Application.Transpose(dt)
End Sub
(mm) 2021/02/01(月) 14:44

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.