ممكن كود ترحيل لشيت منه وله

Sub Test()

    Dim vMenho, vLaho, vDate, vNumber, vVal, wsTransfer As Worksheet, wsMenho As Worksheet, wsLaho As Worksheet, sh As Worksheet, lrTransfer As Long, r As Long, cTarget As Long, c As Long, m As Long

    Application.ScreenUpdating = False

        Set wsTransfer = ThisWorkbook.Worksheets("Transfer")

        Set wsMenho = ThisWorkbook.Worksheets("Menho")

        Set wsLaho = ThisWorkbook.Worksheets("Laho")

        lrTransfer = wsTransfer.Cells(Rows.Count, "B").End(xlUp).Row

        vDate = wsTransfer.Range("A2").Value

        vNumber = wsTransfer.Range("C2").Value

        If vDate = Empty Or vNumber = Empty Then MsgBox "Date And Number Is Necessary", vbExclamation: Exit Sub

        For r = 3 To lrTransfer

            cTarget = wsTransfer.Cells(r, 4).Value

            vMenho = wsTransfer.Cells(r, 5).Value

            vLaho = wsTransfer.Cells(r, 6).Value

            If (vMenho = Empty And vLaho = Empty) Or Not IsNumeric(cTarget) Then GoTo Skipper

            If IsNumeric(vMenho) And Not IsEmpty(vMenho) Then

                Set sh = wsMenho: c = cTarget: vVal = vMenho

            ElseIf IsNumeric(vLaho) And Not IsEmpty(vLaho) Then

                Set sh = wsLaho: c = cTarget: vVal = vLaho

            End If

            m = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1

            sh.Cells(m, 1).Value = vDate

            sh.Cells(m, 2).Value = wsTransfer.Cells(r, 2).Value

            sh.Cells(m, 3).Value = vNumber

            sh.Cells(m, c + 3).Value = vVal

Skipper:

        Next r

    Application.ScreenUpdating = True

    MsgBox "Done...", vbInformation, "YasserKhalil Excel-Egy"

End Sub