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

السلام عليكم 
[ندعوك للتسجيل في المنتدى أو التعريف بنفسك لمعاينة هذه الصورة]
نظرا لكثرة الاسئلة عن طريقة الترحيل لاعمدة غير مرتبة ومتفرقة وخلافة من هذه الامور 
قمت بعمل ترحيل يناسب اغلب الاخوة في احتياجاتهم 
الكود مرن جدا كل ما عليك هو تحديد اسم صفحة ادخال البيانات وصفحة قاعدة البيانات 
وارقام اعمدة البداية لادخال البيانات وايضا اول صف به بيانات 
وعدد الاعمدة المراد الترحيل منها 
والنقطة الاهم والمميزة وهي ترتيب اعمدة صفحة الادخال بما يقابلها من اعمدة قاعدة البيانات 
وتستطيع ترك اعمدة بين اعمدة الترحيل بدون الترحيل لها 
الكود 

الكود:

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

اترك لكم التجربة لان الوقت لا يسمح لعدة محاولات اذاصادفتكم اي مشاكل يرجى ارفاقها في مشاركة اسفل الموضوع 
الملف مرفق
[ندعوك للتسجيل في المنتدى أو التعريف بنفسك لمعاينة هذا الرابط]