Ｅｘｃｅｌのデータでコピペの良い方法は？

質問

出社日　帰社日 氏名　出社時間　帰社時間　仕事内容
171216　171216　伊藤　　8:00　 17:00　　　○○
171216 171216 伊藤　　空白　　 空白 △△
171218 171219　伊藤 8:00　　 10:00　　　○○
171220 171221　伊藤　　8:00 14:00　　　○○
171221 171222　伊藤 空白　　 空白　　　 ××
171225 171226　伊藤　　8:00 10:00　　　□□

このようなデータを

日付 出社時間　退社時間
171216 　8:00 17:00
171217 空白　　　空白
171218　 8:00 空白
171219　 空白　　　10:00
171220 8:00 空白
171221 空白　　　14:00

このように日付毎に出社時間、退社時間のみ抜き出して、違うシートに作成したいのですが、何か良いコピペの方法など
有りましたらお教えいただきたく、宜しくお願いします。

わかりにくい上にデータの表示が見にくくて、すいません。

回答No.9

Wendy02

こんばんは。Wendy02です。

＞マクロが理解できていないと無理なようでしたら、はっきりおっしゃっていただけたらありがたいです。

そんなことはありません。こちらが作ったマクロを貼り付けるだけですから、記録マクロでマクロを記録したことがあれば、なお良いのですが、なくてもキーを押していくだけです。後は、私が、マクロがどのぐらい相手本位に作っているか、とか、私がご質問を勘違いしていなかったとか、とか、私自身の問題だと思います。今回は、内容こそは簡単なのですが、細かいところに気を使ったつもりです。コアになる部分は、ほんのちょっとで、後は、ユーザーさんをまご付かせないための配慮です。

※ マクロの取り付け方
Alt　+　 F11 (Altを押しながらF11）を押すと、Visual Basic Editor 画面が出てきます。
次に、メニューの[挿入]－[標準モジュール]と開けて、クリックすると、画面が現れますので、以下のコードを貼り付けて、

貼り付けたら、Alt　+　Q で、画面を閉じます。

'<標準モジュールに貼り付けてください。>
'---------------------------------------------------
'Option Explicit
Sub CopyArrangePickup()
'出社・帰社データを振り分けるマクロ
　 Dim inData() As Variant
　 Dim outData() As Variant
　 Dim i As Long
　 Dim j As Long
　 Dim k As Long
　 Dim r As Range
　 Dim r1 As Range
　 Dim r2 As Range
　 Dim mRow1 As Long
　 Dim mRow2 As Long
　 Dim PastePos As Range
　 ReDim inData(1, 0)
　 ReDim outData(1, 0)

　 'フィルター選択モードチェック
　 If ActiveSheet.FilterMode = False Then MsgBox "オートフィルターの選択モードではありません。", 64: Exit Sub

　 'データ取得
　 On Error Resume Next
　 Application.SendKeys "{HOME}{END}"
　 Set r = Application.InputBox("データソースの左上端のタイトル・セルを選択してください。", "データコピー", "$A$1", Type:=8)
　 If r Is Nothing Then Exit Sub
　 Set r = r.Cells(1)
　 Beep
　 Set r1 = Range(r, r.End(xlDown)).Resize(, 5) '必要なデータが5列目まで
　 On Error GoTo 0

　 If r1 Is Nothing Then: Exit Sub
　 If Not (WorksheetFunction.CountA(r1.Rows(1)) = 5 And r.Cells(1).Value <> "") Then MsgBox "正しく最左列を選択してください。", 16: Exit Sub
　 '1行目をタイトル行とする
　 For i = 2 To r1.Rows.Count
　　　ReDim Preserve inData(1, k)
　　　ReDim Preserve outData(1, k)
　　　If r1.Cells.EntireRow.Hidden = False Then
　　　　 inData(0, k) = r1.Cells(i, 1).Value2
　　　　 inData(1, k) = r1.Cells(i, 4).Text
　　　　 outData(0, k) = r1.Cells(i, 2).Value2
　　　　 outData(1, k) = r1.Cells(i, 5).Text
　　　　 k = k + 1
　　　End If
　 Next i

　 'ペースト部分

PasteposFind:

　 On Error Resume Next
　 Set PastePos = Application.InputBox("ペーストする場所の左上端を選択してください。", "データペースト", "$A$1", Type:=8)
　 On Error GoTo 0
　 If PastePos Is Nothing Then Exit Sub
　 If PastePos.Value = "" Or PastePos.Offset(2).Value = "" Then
　　　MsgBox "表がないと貼り付けられません。"
　　　GoTo PasteposFind
　 End If
　 If PastePos.Address = r.Address And _
　 PastePos.Parent.Name = r.Parent.Name Then MsgBox "同じ場所には貼り付けることが出来ません。", 64: GoTo PasteposFind

　 Set r2 = Range(PastePos, PastePos.End(xlDown))
　 Application.Goto r2.Cells(1)
　 With r2.Offset(1, 1).Resize(r2.Rows.Count - 1, 2)
　　 If WorksheetFunction.CountA(.Cells) > 1 Then
　　　 If MsgBox("データのみ削除しますがよろしいですか？", vbOKCancel) = vbCancel Then Exit Sub
　　　　　.ClearContents
　　 End If
　 End With
　 Application.ScreenUpdating = False
　 For j = LBound(inData, 2) To UBound(inData, 2)
　　　On Error Resume Next
　　　mRow1 = 0
　　　mRow1 = WorksheetFunction.Match(inData(0, j), r2, 0)
　　　If mRow1 > 0 And inData(1, j) <> "" Then
　　　　 r2.Cells(mRow1, 2).Value = inData(1, j)
　　　End If
　　　mRow2 = 0
　　　mRow2 = WorksheetFunction.Match(outData(0, j), r2, 0)
　　　If mRow2 > 0 And outData(1, j) <> "" Then
　　　　 r2.Cells(mRow2, 3).Value = outData(1, j)
　　　End If
　　　On Error GoTo 0
　 Next j
　 Set r = Nothing: Set r1 = Nothing: Set r2 = Nothing
　 Set PastePos = Nothing
　 Application.ScreenUpdating = True
End Sub

'-------------貼り付け終わり-----------------------------------

なお、このままですと、起動が面倒なので、できれば、コマンドボタンを取り付けると便利です。（ショートカットですと、他の方が使う時に分りにくいです。）

取り付け方は、メニューバーの何もないところを右クリックすると、カスケードメニューが現れますから、その中で、[コントロールツールボックス]　をクリックしてください。
その中をマウスポインターでなぞっていくと、[コマンドボタン]というクリーム色のポップアップ・ヒントが現れますので、[クリック]

ワークシート上で、適当な場所をドラッグして、四角い枠を囲みますと、ボタンになります。白い小さな四角□が並んでいる状態かと思います。それを[ダブルクリック]すると、画面が、VB エディター画面に変ります。

Private Sub CommandButton1_Click()

End Sub
　　　↑
このようになっていますので、
　　このようにします。そのまま、全部を貼り付けてもよいです。
'-------------------------------
Private Sub CommandButton1_Click()
Call　CopyArrangePickup　'書き込み
End Sub
'-------------------------------

画面の上部のツールバーには、青い三角定規が凹んでいますので、[クリック]

もう一度、Alt + Q で、画面を閉じてしまいます。
また、メニューの何もないところで、右クリックして、カスケードメニューの中の[コントロールツール・ボックス]をクリックすれば、このメニューは消えます。

後は、そのボタンをクリックすれば、実行できます。
○ マクロの実行の前に、

※オート・フィルターで、氏名の1人を選択します。
選択していないと、マクロは、進んでくれません。

ペーストのシートには、すでに、以下のように、時系列に日付が並べられていることが条件です。私の作ったマクロは、日付のあるところを探しますので、ないものは転記してくれません。それを気をつけてください。

データは、どちらも、必ずしも、左端上のA1 から始まっていなくてもよいです。

ペースト先は、

日付　　出社時間　　　退社時間
171216　　←元のソースデータがシリアル値なら、シリアル値で
171217　　統一してください。数字なら数字で可能です。
171218　　文字の数字と数値では、検索しません。
171219
171220
171221
171222
171223
171224　　　　出社時間と退社時間にデータがあると、削除して良いか聞いてきます。

マクロは、順を追って、メッセージボックスが現れます。ペーストする時は、シートを替えることが出来ます。

補足

何も分からない見ず知らずの私に、こんなに丁寧にご回答下さって、本当にありがとうございます（嬉涙(T_T)）
きっと貴重なお時間を割いて作ってくださったのでしょう。
本当に感謝していますm(_ _)m
一応、お教えいただいたとおり、マクロを組んでみましたが、
下のように何故か振り分けがうまくいきませんでした。
どこか私のやり方がおかしいとは思うのですが、もしお時間が有れば、教えてください。

《元のデータ》
出社日　帰社日　氏名　出社時間　帰社時間
171216　171216　伊藤　　　7:20　　　18:30
171216　171217　伊藤　　　19:16　　　10:13
171219　171219　伊藤　　　空白　　　空白
171219　171220　伊藤　　　20:30　　　15:00
171219　171219　伊藤　　　7:50　　　　16:10
171220　171220　伊藤　　　空白　　　空白　　　　　　

《マクロで振り分けたデータ》
日付　　出社時間　　帰社時間
171216　　空白　　　　空白
171217　　空白　　　　空白
171218　　8:45　　　　空白
171219　　9:05　　　　空白
171220　　7:20　　　　空白
171221　　空白　　　　空白

本当にお時間が有るときで結構です。