نظرا لكثرة الاسئلة عن طريقة الترحيل لاعمدة غير مرتبة ومتفرقة وخلافة من هذه الامور
والنقطة الاهم والمميزة وهي ترتيب اعمدة صفحة الادخال بما يقابلها من اعمدة قاعدة البيانات
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
اترك لكم التجربة لان الوقت لا يسمح لعدة محاولات اذاصادفتكم اي مشاكل يرجى ارفاقها في مشاركة اسفل الموضوع