VBA AutoFilterで複数条件でデータを抽出、また別の条件で抽出を繰り返し

Question

前提

2つの表がありまして、日付と時間が一致する行のデータをもう一つの表にコピーして、また別の日付時間のデータをコピーしたいです。AutoFilterを使い複数条件の抽出まではできたのですが、繰り返し作業させるところで躓いています。VBAを学び始めて2週間ほどで見当はずれなことかもしれませんがご教授をお願いいたします。

実現したいこと

AutoFilterの抽出条件を変数を使って動的にして
抽出先のシート全部にデータコピーさせたいです。

発生している問題・エラーメッセージ

抽出先のデータ全部がコピーされてしまいます。

該当のソースコード

Sub 改めて日付時間を表示形式にする繰り返し()
    Dim ws As Worksheet
    Set ws = Sheets("抽出先")
    With ws.UsedRange
        Dim i
        For i = 2 To .Rows.Count
 
            Worksheets("抽出元").Range("A1").AutoFilter 1, Format(Worksheets("抽出先").Cells(i, 1), "yyyy/m/d")
            Worksheets("抽出元").Range("A1").AutoFilter 2, Format(Worksheets("抽出先").Cells(i, 2), "hh:mm:ss")
    
   
    
    
             With Worksheets("抽出元
").Range("A1").CurrentRegion
            .Resize(.Rows.Count - 1).Offset(1, 0).Copy Worksheets("抽出先").Cells(i, 7)
            End With
    
    
            Worksheets("抽出元").Range("A1").AutoFilter
        Next
     End With
     ws.AutoFilterMode = False
     
 End Sub

試したこと

オートフィルターの検索条件をセルの値で検索するようにして
セルを変数で2行目から最終行まで変動するように試してみましたが
でたらめにコピーされてしまいます。

補足情報（FW/ツールのバージョンなど）

日付時間に合うデータを抽出したいです。
抽出先のシート（この表にコピーしたい）
|日付|時間|抽出先シートの項目がF列まで|G列辺りにコピー　　　　　　
|2015.1.5|22：55：00|・・・|　　　抽出元の行をコピー
|2015.2.5|21：30：00|・・・|　　　以下繰り返し

抽出元のシート
|日付|時間|抽出元のシート内容G列まで|
|2015.1.5|22：55：00|・・・|
|2015.1.20|15：30：00|・・・|
|2015.1.29|16：00：00|・・・|
|2015.2.5|21：30：00|・・・|
|2018.3.5|14：25：00|・・・|

Comments

[marebito777]

Sub 改めて日付時間を表示形式にする繰り返し()
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
With ws.UsedRange
Dim i
For i = 2 To .Rows.Count

Worksheets("Sheet2").Range("A1").AutoFilter 1, Format(Worksheets("sheet1").Cells(i, 1), "yyyy/m/d")
Worksheets("Sheet2").Range("A1").AutoFilter 2, Format(Worksheets("sheet1").Cells(i, 2), "hh:mm:ss")

With Worksheets("Sheet2").Range("A1").CurrentRegion
.Resize(.Rows.Count - 1).Offset(1, 0).Copy Worksheets("Sheet1").Cells(i, 7)
End With

Worksheets("Sheet2").Range("A1").AutoFilter
Next
End With
ws.AutoFilterMode = False

End Sub

[marebito777]

すいません。コードがちゃんと張り付けられていなかったみたいなので改めて添付いたします。

[hatena19]

質問は編集できますので、質問の方を修正してください。
コードの前後に ``` を挿入してください。

```vba
ここにコードを記述
```

現状はコードの途中に ``` が挿入されているのでおかしな表示になってます。

あと、シートはスクリーンキャプチャーで画像にして、挿入すると状況がわかりやすいのて回答も付きやすくなると思います。

[hatena19]

抽出元の 日付|時間 ですが、重複はありますか。
つまり、AutoFilter をかけたとき、抽出されるデータは1件のみですか。

[marebito777]

ありがとうございます。質問の編集できました。
日付、時間の重複はありません。該当データは1件のみです。

Answer 1

解決済みですが、参考までに連想配列(Dictionary)を使ったコード例。

Sub 改めて日付時間を表示形式にする繰り返し1()
    Dim i As Long
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    With Worksheets("Sheet2").Cells(1).CurrentRegion
        For i = 2 To .Rows.Count
            Set dic(Format(.Cells(i, 1), "yyyy/m/d") & " " & Format(.Cells(i, 1), "hh:mm:ss")) = .Rows(i)
        Next
    End With
    
    With Sheets("Sheet1").UsedRange
        For i = 2 To .Rows.Count
            Dim key As String: key = Format(.Cells(i, 1), "yyyy/m/d") & " " & Format(.Cells(i, 1), "hh:mm:ss")
            If dic.Exists(key) Then dic(key).Copy .Cells(i, 7)
        Next
    End With
End Sub

Answer 2

Sub 改めて日付時間を表示形式にする繰り返し()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
    
    With ws1.UsedRange
        Dim i
        For i = 2 To .Rows.Count
            ws2.Range("A1").AutoFilter 1, Format(ws1.Cells(i, 1), "yyyy/m/d")
            ws2.Range("A1").AutoFilter 2, Format(ws1.Cells(i, 2), "hh:mm:ss")
            
            With ws2.Range("A1").CurrentRegion
                Dim rng As Range
                Set rng = Intersect(.Cells, .Offset(1))
                If IsVisible(rng) Then rng.Copy ws1.Cells(i, 7)
            End With
            
            ws2.Range("A1").AutoFilter
        Next
    End With
    ws1.AutoFilterMode = False
End Sub

Function IsVisible(r As Range) As Boolean
    On Error Resume Next
    IsVisible = r.SpecialCells(xlCellTypeVisible).Count > 0
End Function

Comments

[marebito777]

回答ありがとうございます。
一歩、解決に向けて進めました。
完全解決は残念ながらまだしていませんが、
また、新たな疑問点や問題点も出てきましたので
新しく質問を立ち上げます。
ベストアンサーにさせていただきます。
ありがとうございました。
まだまだ初心者で、ご教授頂いたコードを一つ一つ分解して調べて理解していってるレベルです。
また私の質問を見られましたら、何卒ご教授のほどよろしくお願いいたします。

[jinoji]

一応解説しておくと、
元々のコードで起きていた不具合は、「オートフィルターに複数条件を指定した結果、条件を満たす行が一つもないケース」の時に起きているのではないかと推測しました。
セル範囲のCopyの際に、１行でも表示行がある場合は非表示行を無視して表示行だけコピーされますが、
全行が非表示行の場合は、非表示行が無視されずそのままコピーされてしまいます。
ですので、IsVisibleという手作り関数で、コピーする前に対象セルが全て非表示かどうかを確かめ、
もしそうならコピーしないようにしてみました。

Answer 3