[[20190806191603]]　『日毎の最早時刻と最遅時刻の抽出』（ぺら）　ページの最後に飛ぶ

『日毎の最早時刻と最遅時刻の抽出』（ぺら）

ご教示お願いいたします

入退館に関して各人ごとに1ヶ月単位で、以下のようなデータがございます。

氏名　日付　　　入館時刻　退館時刻
山田　2019/8/1　7:45　　　17:05
田中　2019/8/1　8:00　　　17:30
佐藤　2019/8/1　7:50　　　18:03
・・　2019/8/1　8:02　　　17:55
山田　2019/8/2　7:50　　　19:05
田中　2019/8/2　7:52　　　18:55
佐藤　2019/8/2　7:59　　　18:30
・・　2019/8/2　8:03　　　18:02
～　　　
山田　2019/8/31　8:10　　　19:20
田中　2019/8/31　7:55　　　17:52
佐藤　2019/8/31　7:58　　　17:35
・・　2019/8/31　8:04　　　18:30

上記のデータから、下記のようにデータを抽出出来ますでしょうか？

日付　　　最早入館者　最早入館時刻　最遅退館者　最遅退館時刻
2019/8/1　山田　　　　7:45　　　　　佐藤　　　　18:03
～
2019/8/31　田中　　　　7:55　　　　　山田　　　　19:20

膨大な人数データで苦心しております。
よろしくお願いいたします。

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

こんな手順でどうですか

１）新規シート作成
２）B列を、１）のA列にコピー
３）A列を、１）のB列にコピー
４）C列を、１）のC列にコピー
５）１）のA列、C列で並び替え
６）１）のA列で重複の削除
７）B列を、１）のD列にコピー
８）A列を、１）のE列にコピー
９）D列を、１）のF列にコピー
10）１）のD列、F列で並び替え
11）１）のD列で重複の削除
12）１）のD列を削除

（マナ） 2019/08/06(火) 20:13

５）の並び替えは、A列、C列ともに昇順です。
10）の並び替えは、D列昇順、F列降順です。

（マナ） 2019/08/06(火) 20:18

 おはようございます　＾＾
眺めてて。。。気が付いた点だけで恐縮ですが職場でよく
見かける光景なのですが、同日で、三人の方が退、出とも
同時刻だった場合は【1分間で三人揃ってタイムカード打刻
はあり得るかと？】どうするのが正解なのでしょうか。。。m(_ _)m
（隠居じーさん） 2019/08/07(水) 08:02

 ↑      じ～さん。。。  いいんだぁ～。。。
いいんだよぉをぉお～それで。。。。　(*^^*)
という事であれば無視してください。
m(_ _)m
（隠居じーさん） 2019/08/07(水) 09:00

＞マナ様

ご丁寧に手順をご教示いただきありがとうございます。
早速、作業させていただきます。

＞隠居じーさん様

同1分間に複数の従業員の入退館について
ご指摘いただきありがとうございます。
現時点では、発生していないようですが
今後の課題とさせていただきます。

初めて投稿させていただきましたが
こんなにも迅速にご対応いただき
お二方には、改めてお礼申し上げます。

（ぺら） 2019/08/07(水) 12:08

 Sub main()
    'Sheet1からSheet2に抽出
    Dim c As Range, r As Range
    Sheets("Sheet2").Cells.ClearContents
    Sheets("Sheet2").Range("A1:E1").Value = Array("日付", "最早入館者", "最早入館時刻", "最遅退館者", "最遅退館時刻")
    For Each c In Sheets("Sheet1").Range("B2:B" & Rows.Count).SpecialCells(2)
        Set r = Sheets("Sheet2").Range("A:A").Find(c.Value, , , xlWhole)
        If r Is Nothing Then
            Set r = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
            r.Value = c.Value
            r.Offset(, 1).Value = c.Offset(, -1).Value
            r.Offset(, 2).Value = c.Offset(, 1).Value
            r.Offset(, 3).Value = c.Offset(, -1).Value
            r.Offset(, 4).Value = c.Offset(, 2).Value
        Else
            If r.Offset(, 2).Value > c.Offset(, 1).Value Then
                r.Offset(, 2).Value = c.Offset(, 1).Value
                r.Offset(, 1).Value = c.Offset(, -1).Value
            End If
            If r.Offset(, 4).Value < c.Offset(, 2).Value Then
                r.Offset(, 4).Value = c.Offset(, 2).Value
                r.Offset(, 3).Value = c.Offset(, -1).Value
            End If
        End If
    Next c
End Sub
（mm） 2019/08/07(水) 12:32

 こんにちは＾＾もうご覧になっていないかもですが。
さらに、ｍｍさんが既にご提案ですが、作ってありましたので。。。バックアップ必須です。
私のはなが～くてダサ～イ、コードですが　(￣▽￣)
何かの足しにでも。。。ならなければゴミ箱にでも。。。 (*^^*)　。。。m(_ _)m

 一か月の情報が　Sheet1　に下記の様なフォーマットであるとして。

     |[A]   |[B]       |[C]       |[D]     
 [1] |氏名　|日付　　　|入館時刻　|退館時刻
 [2] |山田  |2019/8/1  |7:45      |17:05   
 [3] |田中  |2019/8/1  |8:00      |17:30   
 [4] |佐藤  |2019/8/1  |7:50      |18:03   
 [5] |XX    |2019/8/1  |8:02      |17:55   
 [6] |山田  |2019/8/2  |7:50      |19:05   
 [7] |田中  |2019/8/2  |7:52      |18:55   
 [8] |佐藤  |2019/8/2  |7:59      |18:30   
 [9] |XX    |2019/8/2  |8:03      |18:02   
 [10]|田中  |2019/8/31 |6:35      |17:05   
 [11]|佐藤  |2019/8/31 |8:00      |17:30   
 [12]|山田  |2019/8/31 |7:50      |19:15   
 [13]|XX    |2019/8/31 |8:02      |20:50

 Option Explicit
Sub OneInstance01()
    Dim D As Object
    Dim i As Long
    Dim j As Long
    Dim y As Long
    Dim WF As Object
    Dim Base As Variant
    Dim Man()
    Dim Tin()
    Dim TOut()
    Dim Tmp
    Dim r As Range
    Set WF = WorksheetFunction
    Set D = CreateObject("Scripting.Dictionary")
    With Worksheets("Sheet1")
        Base = .Cells(1).CurrentRegion
    End With
    For i = 2 To UBound(Base, 1)
        If Not D.Exists(Base(i, 2)) Then
           ReDim Man(0), Tin(0), TOut(0)
           Man(0) = Base(i, 1)
           Tin(0) = Base(i, 3)
           TOut(0) = Base(i, 4)
           D.Add Base(i, 2), Array(Man, Tin, TOut)
        Else
           Man = D(Base(i, 2))(0)
           Tin = D(Base(i, 2))(1)
           TOut = D(Base(i, 2))(2)
           ReDim Preserve Man(UBound(Man) + 1), Tin(UBound(Tin) + 1), TOut(UBound(TOut) + 1)
           Man(UBound(Man)) = Base(i, 1)
           Tin(UBound(Tin)) = Base(i, 3)
           TOut(UBound(TOut)) = Base(i, 4)
           D(Base(i, 2)) = Array(Man, Tin, TOut)
        End If
    Next
    Worksheets(1).Copy Worksheets(1)
    y = 2
    With ActiveSheet
        .UsedRange.Clear
        .Cells(1).Resize(, 5) = Array("日付", "最早入館者", "最早入館時刻", "最遅退館者", "最遅退館時刻")
        For i = 0 To D.Count - 1
            .Cells(y, 1) = D.keys()(i)
            .Cells(y, 3) = WF.Min(D.items()(i)(1))
            For j = 0 To UBound(D.items()(i)(0))
                If D.items()(i)(1)(j) = .Cells(y, 3).Value Then
                    Tmp = D.items()(i)(0)(j)
                    Exit For
                End If
            Next
            .Cells(y, 2) = Tmp
            .Cells(y, 5) = WF.Max(D.items()(i)(2))
            For j = 0 To UBound(D.items()(i)(0))
                If D.items()(i)(2)(j) = .Cells(y, 5).Value Then
                    Tmp = D.items()(i)(0)(j)
                    Exit For
                End If
            Next
            .Cells(y, 4) = Tmp
            y = y + 1
        Next
        Set r = .UsedRange
        Intersect(r.Offset(1), r, .Range("C:C,E:E")).NumberFormatLocal = "hh:mm"
        .UsedRange.EntireColumn.AutoFit
        Set r = Nothing
        Set WF = Nothing
        Set D = Nothing
        Erase Base, Man, Tin, TOut
    End With
End Sub
（隠居じーさん） 2019/08/07(水) 12:55

コメント返信：

[ 一覧(最新更新順) ]

[[20190806191603]] 『日毎の最早時刻と最遅時刻の抽出』（ぺら） ページの最後に飛ぶ

[[20190806191603]]　『日毎の最早時刻と最遅時刻の抽出』（ぺら）　ページの最後に飛ぶ