مطلوب كود ترحيل بيانات

[yasser_w_2010]

الاساتذه الكرام 

رجو عمل كود ترحيل بيانات من خلايا كثيره واعمدة متفرقه 

الى اخر صف به بيانات 

شاكر لكم جدا على مجهودكم معي 

وشاكر لموقع اوفسينا الممتاذ

المصنف1.xlsm

[احمدزمان]

السلام عليكم و رحمة الله وبركاته

Dim FS As Worksheet, TS As Worksheet
Dim TR, FR, FC, TC
Set FS = Sheets("order2")
Set TS = Sheets("save")
TR = Application.CountA(TS.Range("A:A")) + 3
With TS
3
If Cells(TR, 1) <> "" Then
TR = TR + 1
GoTo 3
End If
.Cells(TR, 1) = FS.Cells(4, 4)
.Cells(TR, 2) = FS.Cells(4, 7)
.Cells(TR, 3) = FS.Cells(5, 4)
.Cells(TR, 4) = FS.Cells(6, 4)
.Cells(TR, 5) = FS.Cells(4, 11)
.Cells(TR, 6) = FS.Cells(5, 11)
.Cells(TR, 7) = FS.Cells(7, 4)
.Cells(TR, 8) = FS.Cells(6, 11)
.Cells(TR, 9) = FS.Cells(7, 11)
.Cells(TR, 10) = FS.Cells(8, 4)
.Cells(TR, 11) = FS.Cells(8, 6)
.Cells(TR, 12) = FS.Cells(8, 8)
.Cells(TR, 13) = FS.Cells(8, 10)
.Cells(TR, 14) = FS.Cells(8, 12)
TC = 17
For FR = 10 To 19
For FC = 2 To 11
.Cells(TR, TC) = FS.Cells(FR, FC)
TC = TC + 1
Next 'FC
Next 'FR
End With

تفضل

 

السلام عليكم و رحمة الله وبركاته

Dim FS As Worksheet, TS As Worksheet
Dim TR, FR, FC, TC
Set FS = Sheets("order2")
Set TS = Sheets("save")
TR = Application.CountA(TS.Range("A:A")) + 3
With TS
3
If Cells(TR, 1) <> "" Then
TR = TR + 1
GoTo 3
End If
.Cells(TR, 1) = FS.Cells(4, 4)
.Cells(TR, 2) = FS.Cells(4, 7)
.Cells(TR, 3) = FS.Cells(5, 4)
.Cells(TR, 4) = FS.Cells(6, 4)
.Cells(TR, 5) = FS.Cells(4, 11)
.Cells(TR, 6) = FS.Cells(5, 11)
.Cells(TR, 7) = FS.Cells(7, 4)
.Cells(TR, 8) = FS.Cells(6, 11)
.Cells(TR, 9) = FS.Cells(7, 11)
.Cells(TR, 10) = FS.Cells(8, 4)
.Cells(TR, 11) = FS.Cells(8, 6)
.Cells(TR, 12) = FS.Cells(8, 8)
.Cells(TR, 13) = FS.Cells(8, 10)
.Cells(TR, 14) = FS.Cells(8, 12)
TC = 17
For FR = 10 To 19
For FC = 2 To 11
.Cells(TR, TC) = FS.Cells(FR, FC)
TC = TC + 1
Next 'FC
Next 'FR
End With

تفضل

 

المصنف1.xlsm

[yasser_w_2010]

اسف لحضرتك ولاكن عندالترحيل لا يرحل اسفل كل خليه فارغه اوقات بيرحل في نفس الصف واوقات بيرحل تحته وبيسيب صف فاضي

[احمدزمان]

منذ ساعه, yasser_w_2010 said:

الف شكر استاذنا الكريم

طلب اخير هل يمكن كود لحذف بعد الترحيل

والف شكر لمجهود حضرتك

العفو

تم اضافة المسح للخلايا المرحلة

منذ ساعه, yasser_w_2010 said:

اسف لحضرتك ولاكن عندالترحيل لا يرحل اسفل كل خليه فارغه اوقات بيرحل في نفس الصف واوقات بيرحل تحته وبيسيب صف فاضي

تم التعديل

المصنف1.xlsm

[yasser_w_2010]

الف الف شكر لحضرتك ولمجهودك و الكود الرائع  ... الف شكر منتدي اوفسينا

اضافة كود منع الترحيل اذا كانت الخلية فارغة

الاساتذه الكرام  .. هل ممكن اضافة الى هذا الكود للاستاذ احمد زمان

بحيث عند خلو الخلايا المظللة بالون الاسود لا تتم عملية الترحيل , وتظهر رسالة اكمل البيانات ... شاكر لكم جدا

المصنف1.xlsm

[احمدزمان]

السلام عليكم و رحمة الله وبركاته

اخي ياسر

انا عادة استخدم دالة داخل الورقة للتاكد من اكتمال البيانات

وكذلك اضع نص الرسالة في خلية داخل الورقة في عمود مخفي

بحيث يمكنك تغييرها متى دعة الحاجة لذلك

 

[احمدزمان]

الخلية N3 بها شرط اكتمال البيانات

=AND(G4<>"";K4<>"";D5<>"";K5<>"";D6<>"";K6<>"";D7<>"";K7<>"";D8<>"";B10<>"")

الخلية N4 تظهر بها اسماء البيانات الناقصة

 

=CONCAT(IF(G4="";E4&" -";"");IF(K4="";I4&" -";"");IF(D5="";B5&" -";"");IF(K5="";I5&" -";"");IF(D6="";B6&" -";"");IF(K6="";I6&" -";"");IF(D7="";B7&" -";"");IF(K7="";I7&" -";"");IF(B10="";H9&" -";""))

الخلية N5 بها نص الرسالة

=IF(N3;"";CONCAT("اكمل ادخال البيانات الناقصة";CHAR(10);CHAR(10);N4))

تم اضافة الى الكود مع الترحيل

If FS.Range("N3") = False Then
Dim Q1
Q1 = FS.Range("N5").Text
MsgBox Q1, vbMsgBoxRight, "خطاء"
Exit Sub
End If

مع التحية

 

y02.xlsm

[yasser_w_2010]

الف شكر لجضرتك 

الف شكر على الدلة الجميله

الف شكر منتدي اوفسينا الحبيب