シート１の情報を複数条件で検索し該当情報をシート２に連続してコピーする

シート１のA列に　１A　１B　２A　２B　３A　３Bという数値が不規則に入力されている
シート１のB列に　斉藤　佐藤　鈴木　等の名前
シート１のC列に　時間
シート１のD列に　休
A列を検索して１A表示ありD列で”休”以外のB列の名前とC列の時間をシート２の１A行のB・C・D・・セルに時間基準で連続してコピーする
シート１のデータは３００行くらいです

シート１
A 　　B 　　　　C 　　　D
1a 　斉藤 　８：２０ 　　休
1b 　佐藤 　９：００
2a 　鈴木 　９：１０
1b 　大田 　９：２０
1a 　加藤 　８：４０
2a 　青木 　８：３０
1a 　青山 　８：４０
3a 　中山 　８：３０ 　　休
3b 　高橋 　９：２０


　　　　　　　　　
シート２
A 　　　　B 　　　　　C　 　　　　D 　　　　E
1a 　　　加藤 　　　　青山
時間 　　８：４０ 　８；４０
1b 　　　佐藤 　　　　大田
時間 　　９：００ 　９：２０
2a 　　　青木 　　　　鈴木
時間 　　８：３０ 　９：１０
2b
時間
3a
時間
3b 　　　高橋
時間 　　９：２０


という表を手作業で１００件ほど毎日やっていますが効率と正確性のためマクロを試していますがうまく出来ません。If　Then　Do　Loop　など見よう見まねですがうまく行きません。どなたか助けてください。よろしくお願いいたします。

No.3 ベストアンサー 回答者： tom04 回答日時： 2017/10/16 08:31

No.1です。

＞シート２の最上行にA列空白のB列名前が連続でコピーされてしまいます

前回のコードは消去し、↓のコードに変更してみてください。
（エラー処理を少し加えています）

Sub Sample2()
Dim i As Long, lastRow As Long, lastCol As Long
Dim c As Range, wS As Worksheet

Set wS = Worksheets("Sheet2")
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
lastCol = wS.UsedRange.Columns.Count
Application.ScreenUpdating = False
If lastCol > 1 Then '//←念のため//
Range(wS.Cells(1, "B"), wS.Cells(lastRow, lastCol)).ClearContents
End If
With Worksheets("Sheet1")
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
If .Cells(i, "A") <> "" Then '//←追加★//
If .Cells(i, "D") <> "休" Then
Set c = wS.Range("A:A").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
lastCol = wS.Cells(c.Row, Columns.Count).End(xlToLeft).Column + 1
.Cells(i, "B").Copy wS.Cells(c.Row, lastCol)
.Cells(i, "C").Copy wS.Cells(c.Row + 1, lastCol)
End If
End If '//←追加★//
Next i
End With
wS.Activate
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

今度はどうでしょうか？

※　未検証なので、お望み通りにならなかったらごめんなさい。m(_ _)m

この回答へのお礼

本当に有難うございました。見事に出来ました。有難うございました。
各コードの意味は勉強します。これで処理が大幅に楽になり正確になりました。感謝です。

お礼日時：2017/10/16 20:21

No.2 回答者： mike_g 回答日時： 2017/10/16 00:41

Sheet1 において、

１．列Ｆを作業列として、次式を入力したセル F1 を下方にズズーッとオートフィル
￣￣ =HOUR(C1)*100+MINUTE(C1)+ROW()/1000
Sheet2 において、
２．下記の左端に示す各セルにそれぞれの右側の式を入力して、範囲B1:B2 を右隣にオートフィル
￣￣B1: =IFERROR(INDEX(Sheet1!$B$1:$B$350,MATCH(SMALL(IF((Sheet1!$A$1:$A$350=$A1)*(Sheet1!$D$1:$D$350<>"休"),Sheet1!$F$1:$F$350,""),COLUMN(A1)),Sheet1!$F$1:$F$350,0)),"")
￣￣B2: =IFERROR(INDEX(Sheet1!$C$1:$C$350,MATCH(SMALL(IF((Sheet1!$A$1:$A$350=$A1)*(Sheet1!$D$1:$D$350<>"休"),Sheet1!$F$1:$F$350,""),COLUMN(A1)),Sheet1!$F$1:$F$350,0)),"")
￣￣【お断り】上式は必ず配列数式として入力のこと
３．範囲 B1:C2 を下方にズズーッとオートフィル

この回答へのお礼

有難うございました。配列数式を勉強します。

お礼日時：2017/10/16 22:24

No.1 回答者： tom04 回答日時： 2017/10/15 19:57

こんばんは！

↓の画像のような配置になっているとします。（Sheet1の1行目は項目行）
尚、Sheet2のA列は入力済みだという前提です。
標準モジュールにしてください。

Sub Sample1()
Dim i As Long, lastRow As Long, lastCol As Long
Dim c As Range, wS As Worksheet

Set wS = Worksheets("Sheet2")
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
lastCol = wS.UsedRange.Columns.Count
Application.ScreenUpdating = False
Range(wS.Cells(1, "B"), wS.Cells(lastRow, lastCol)).ClearContents
With Worksheets("Sheet1")
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
If .Cells(i, "D") <> "休" Then
Set c = wS.Range("A:A").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
lastCol = wS.Cells(c.Row, Columns.Count).End(xlToLeft).Column + 1
.Cells(i, "B").Copy wS.Cells(c.Row, lastCol)
.Cells(i, "C").Copy wS.Cells(c.Row + 1, lastCol)
End If
Next i
End With
wS.Activate
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

早速に有難うございました
出来ました！　感激です　有難うございました
シート１A列に空白のセルが存在していて、シート２の最上行にA列空白のB列名前が連続でコピーされてしまいます
ずうずうしいですがこの解決法も教えていただけると幸いです。

お礼日時：2017/10/15 23:42