[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『日毎の最早時刻と最遅時刻の抽出』(ぺら)
ご教示お願いいたします
入退館に関して各人ごとに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 >
1)新規シート作成
2)B列を、1)のA列にコピー
3)A列を、1)のB列にコピー
4)C列を、1)のC列にコピー
5)1)のA列、C列で並び替え
6)1)のA列で重複の削除
7)B列を、1)のD列にコピー
8)A列を、1)のE列にコピー
9)D列を、1)のF列にコピー
10)1)のD列、F列で並び替え
11)1)のD列で重複の削除
12)1)のD列を削除
(マナ) 2019/08/06(火) 20:13
(マナ) 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
こんにちは^^もうご覧になっていないかもですが。 さらに、mmさんが既にご提案ですが、作ってありましたので。。。バックアップ必須です。 私のはなが〜くてダサ〜イ、コードですが ( ̄▽ ̄) 何かの足しにでも。。。ならなければゴミ箱にでも。。。 (*^^*) 。。。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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.