ثبت اطلاعات در شیت مقصد بر اساس شروط تعیین شده

سلام و وقت بخیر

بر اساس دو شرط در دو سلول اطلاعات product1 و farm 1 میخوام در ردیف زوج در شیت مقصد و در صورتی که product 2 و farm 2 باشه در ردیف خالی فرد شیت مقصد درج بشه

این فرمول در قسمت دوم عمل نمیکنه

ممنون میشم راهنمایی بفرمایین

Option Explicit

Sub Button_Click()

Dim source As Worksheet

Dim destination As Worksheet

Dim a As Integer

Dim j As Integer

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

If Sheet2.Cells(2, 1) = "product1" And Sheet2.Range("a1") = "farm1" Then

Set source = Worksheets("sheet2")

Set destination = Worksheets("sheet4")

a = 1

Do Until Sheet4.Cells(a, 2) = "" And a Mod 2 <> 0

a = a + 1

Loop

For j = 2 To 91

Sheet4.Cells(a, j) = Sheet2.Cells(2, j)

Next j

ElseIf Sheet2.Cells(2, 1) = "product2" And Sheet2.Range("a1") = "farm1" Then

Set source = Worksheets("sheet2")

Set destination = Worksheets("sheet4")

Do Until Sheet4.Cells(a, 2) = "" And a Mod 2 = 0

a = a + 1

Loop

For j = 2 To 91

Sheet4.Cells(a, j) = Sheet2.Cells(2, j)

Next j

End If

If Sheet2.Cells(2, 1) = "product1" And Sheet2.Range("a1") = "farm2" Then

Set source = Worksheets("sheet2")

Set destination = Worksheets("sheet1")

a = 1

Do Until Sheet1.Cells(a, 2) = "" And a Mod 2 <> 0

a = a + 1

Loop

For j = 2 To 91

Sheet1.Cells(a, j) = Sheet2.Cells(2, j)

Next j

ElseIf Sheet2.Cells(2, 1) = "product2" And Sheet2.Range("a1") = "farm2" Then

Set source = Worksheets("sheet2")

Set destination = Worksheets("sheet1")

Do Until Sheet1.Cells(a, 2) = "" And a Mod 2 = 0

a = a + 1

Loop

For j = 2 To 91

Sheet1.Cells(a, j) = Sheet2.Cells(2, j)

Next j

End If

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

End Sub