特定の条件に合致したセルを別のブックに貼り付け

画像のＡのブックがあります。
ここから必要な部分だけＢのブックに貼り付けたいです。

条件1　B列が入力ＢＯＸに入力した日付と同じ
条件2　Ｄ列が空白のもの
条件3　Ｃ列が空白のものはブックBの国内に
　Ｃ列に値が入ったものはブックBの海外A列のシリアルのみ貼り付ける
以上の動作をVBAで行いたいです。

お詳しい方宜しくお願いいたします。

No.1 ベストアンサー 回答者： tatsumaru77 回答日時： 2021/12/11 18:37

以下のマクロを標準モジュールに登録してください。

AブックはA.xlsx BブックはB.xlsx としています。
シート名が提示されていないのでAブックのSheet1,BブックのSheet1を対象にしています。
上記はあなたの環境にあわせて適切に設定してください。


Option Explicit
Public Sub シリアル転記()
Dim ans As Variant
Dim wsA As Worksheet
Dim wsB As Worksheet
Dim maxrow As Long
Dim naiRow As Long
Dim gaiRow As Long
Dim wrow As Long
ans = InputBox("日付を入力してください", "日付入力")
If ans = "" Then Exit Sub
If IsDate(ans) = False Then
MsgBox ("日付エラー")
Exit Sub
End If
Set wsA = Workbooks("A.xlsx").Worksheets("Sheet1")
Set wsB = Workbooks("B.xlsx").Worksheets("Sheet1")
wsB.Rows("2:" & Rows.count).Clear
naiRow = 2
gaiRow = 2
maxrow = wsA.Cells(Rows.count, "A").End(xlUp).Row
For wrow = 2 To maxrow
If wsA.Cells(wrow, "B").Value = DateValue(ans) And wsA.Cells(wrow, "D").Value = "" Then
If wsA.Cells(wrow, "C").Value = "" Then
wsB.Cells(naiRow, "A").Value = wsA.Cells(wrow, "A").Value
naiRow = naiRow + 1
Else
wsB.Cells(gaiRow, "B").Value = wsA.Cells(wrow, "A").Value
gaiRow = gaiRow + 1
End If
End If
Next
MsgBox ("完了")
End Sub

この回答へのお礼

ありがとうございます！
おかげで理想の形になりました。

お礼日時：2021/12/12 07:12