ترحيل مرن وسريع وسهل ضبطه

Sub Yasser()

    Dim Add As Worksheet

    Dim Data As Worksheet

    Dim ar1 As Variant

    Dim ar2 As Variant

    Dim arr As Variant

    Dim v As Long, rw, x, xx

    Const co1 As Long = 2 'رقم اول عمود لصفحة ادخال البيانات

    Const co2 As Long = 3  'رقم اول عمود لصفحة قاعدة البيانات

    Const ro1 As Long = 5 'رقم اول صف ترحيل بيانات في صفحة ادخال البيانات

    Const co_num1 As Long = 20 ' عدد الاعمدة المراد الترحيل منها

    Set Add = Sheets("Enter") 'اسم صفحة ادخال البيانات

    Set Data = Sheets("Data") 'اسم صفحة قاعدة البيانات

    ar1 = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 16) ' ترتيب اعمدة صفحة الادخال

    ar2 = Array(2, 1, 3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 16) 'ترتيب اعمدة قاعدة البيانات بما يقابلها من صفحة ادخال البيانات

    arr = Add.Range(Add.Cells(ro1, co1), Cells(Add.Cells(Rows.Count, co1).End(xlUp).Row, co1 + co_num1)).Value

    If Add.Cells(ro1, co1) = "" Then MsgBox "يرجى ادخال البيانات ثم الترحيل": Exit Sub

    v = Data.Cells(Rows.Count, co2).End(xlUp).Row

        For xx = LBound(ar2) To UBound(ar2)

        ReDim y(1 To UBound(arr, 1))

            For x = LBound(arr) To UBound(arr)

            If ar2(xx) <> "" Then

               rw = rw + 1

                y(rw) = arr(x, ar1(xx))

            End If

        Next

    If rw > 0 Then Data.Cells(v, co2 + (ar2(xx) - 1))(2, 1).Resize(UBound(y, 1)).Value = Application.Transpose(y)

        Erase y

        rw = 0

    Next

    Erase arr

    Add.Range(Add.Cells(ro1, co1), Cells(Add.Cells(Rows.Count, co1).End(xlUp).Row, co1 + co_num1)).ClearContents

    MsgBox "Done............"

End Sub