طلب تعديل كود للترحيل

حرود · مارس 16, 2015

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

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

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

عاوز تعديل هاد الكود ترحيل فاتورة من (2b) حتى (54b)

ترحيل في شيت mat


Sub AddData()
Application.ScreenUpdating = False
smsm.Range("d12").Select
If smsm.Range("d12").Value = "" Then
MsgBox "الرجاء ادخال الاسم قبل عملية الاضافة"
Exit Sub
End If
Dim en As Longen = good.Range("e15000").End(xlUp).Row + 1
good.Cells(en, 4) = smsm.Range("d10").Value
good.Cells(en, 5) = smsm.Range("d11").Value
good.Cells(en, 6) = smsm.Range("d12").Value
good.Cells(en, 7) = smsm.Range("c15").Value
good.Cells(en, 8) = smsm.Range("d15").Value
good.Cells(en, 9) = smsm.Range("e15").Value
good.Cells(en, 10) = smsm.Range("c16").Value
good.Cells(en, 11) = smsm.Range("d16").Value
good.Cells(en, 12) = smsm.Range("e16").Value
good.Cells(en, 13) = smsm.Range("c17").Value
good.Cells(en, 14) = smsm.Range("d17").Value
good.Cells(en, 15) = smsm.Range("e17").Value
good.Cells(en, 16) = smsm.Range("c18").Value
good.Cells(en, 17) = smsm.Range("d18").Value
good.Cells(en, 18) = smsm.Range("e18").Value
good.Cells(en, 19) = smsm.Range("c19").Value
good.Cells(en, 20) = smsm.Range("d19").Value
good.Cells(en, 21) = smsm.Range("e19").Value
good.Cells(en, 22) = smsm.Range("c20").Value
good.Cells(en, 23) = smsm.Range("d20").Value
good.Cells(en, 24) = smsm.Range("e20").Value
good.Cells(en, 25) = smsm.Range("c21").Value
good.Cells(en, 26) = smsm.Range("d21").Value
good.Cells(en, 27) = smsm.Range("e21").Value
good.Cells(en, 28) = smsm.Range("c22").Value
good.Cells(en, 29) = smsm.Range("d22").Value
good.Cells(en, 30) = smsm.Range("e22").Value
good.Cells(en, 31) = smsm.Range("c23").Value
good.Cells(en, 32) = smsm.Range("d23").Value
good.Cells(en, 33) = smsm.Range("e23").Value
good.Cells(en, 34) = smsm.Range("c24").Value
good.Cells(en, 35) = smsm.Range("d24").Value
good.Cells(en, 36) = smsm.Range("e24").Value
good.Cells(en, 37) = smsm.Range("c25").Value
good.Cells(en, 38) = smsm.Range("d25").Value
good.Cells(en, 39) = smsm.Range("e25").Value
good.Cells(en, 40) = smsm.Range("c26").Value
good.Cells(en, 41) = smsm.Range("d26").Value
good.Cells(en, 42) = smsm.Range("e26").Value
good.Cells(en, 43) = smsm.Range("c27").Value
good.Cells(en, 44) = smsm.Range("d27").Value
good.Cells(en, 45) = smsm.Range("e27").Value
good.Cells(en, 46) = smsm.Range("c28").Value
good.Cells(en, 47) = smsm.Range("d28").Value
good.Cells(en, 48) = smsm.Range("e28").Value
good.Cells(en, 49) = smsm.Range("c29").Value
good.Cells(en, 50) = smsm.Range("d29").Value
good.Cells(en, 51) = smsm.Range("e29").Value
good.Cells(en, 52) = smsm.Range("c30").Value
good.Cells(en, 53) = smsm.Range("d30").Value
good.Cells(en, 54) = smsm.Range("e30").Value
good.Cells(en, 55) = smsm.Range("c31").Value
good.Cells(en, 56) = smsm.Range("d31").Value
good.Cells(en, 57) = smsm.Range("e31").Value
good.Cells(en, 58) = smsm.Range("c32").Value
good.Cells(en, 59) = smsm.Range("d32").Value
good.Cells(en, 60) = smsm.Range("e32").Value
good.Cells(en, 61) = smsm.Range("c33").Value
good.Cells(en, 62) = smsm.Range("d33").Value
good.Cells(en, 63) = smsm.Range("e33").Value
good.Cells(en, 64) = smsm.Range("c34").Value
good.Cells(en, 65) = smsm.Range("d34").Value
good.Cells(en, 66) = smsm.Range("e34").Value
good.Cells(en, 66) = smsm.Range("e34").Value
good.Cells(en, 3) = smsm.Range("e9").Value
smsm.Range("d11:e11,d12:e12,c15:e34").ClearContents
 
     good.Range("b8:h1000").Sort Key1:=good.Range("b8"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
smsm.Range("e9") = smsm.Range("e9") + 1
smsm.Range("c11").Select
End Sub

الفاتورة.zip

**شوقي ربيع** · مارس 16, 2015

السلام عليكم

اولا لم اجد الكود السابق في الملف المرفق

ثانيا توجد حاجا اسمها الحلاقات التكرارية تغنيك عن مئات الاسطر

وهذا التعديل للكود الذي ادرجته اعلاه على حسب فهمي للطلبك

Sub AddData()
Application.ScreenUpdating = False
smsm.Range("d12").Select
If smsm.Range("d12").Value = "" Then
MsgBox "ÇáÑÌÇÁ ÇÏÎÇá ÇáÇÓã ÞÈá ÚãáíÉ ÇáÇÖÇÝÉ"
Exit Sub
End If
Dim en As Long: en = good.Range("e15000").End(xlUp).Row + 1
Dim i As Long:  For i = 2 To 54
                good.Cells(en, i) = smsm.Range("d" & i + 8).Value
                Next
smsm.Range("d11:e11,d12:e12,c15:e34").ClearContents
 
     good.Range("b8:h1000").Sort Key1:=good.Range("b8"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
smsm.Range("e9") = smsm.Range("e9") + 1
smsm.Range("c11").Select
End Sub

حرود · مارس 16, 2015

السلام عليكم اخي شوقي ربيع بارك لله فيك انا لم ادرج الكود في الملف تاركت الخيار لي من يرد تعديل الملف

ارجو منك اضافت الكود في الملف لو سمحت ليس عندي خبرا في اللكواد

اسال الله ان يفرج همك

حرود · مارس 17, 2015

ارجو تركيب الكود بارك الله فيكم

حرود · مارس 17, 2015

السلام عليكم ارجو المساعدة

جزاكم الله خير

ياسر خليل أبو البراء · مارس 18, 2015

أخي الحبيب قم بنسخ الكود الذي تفضل به العلامة شوقي ربيع

وفي ملفك اضغط Alt + F11 ثم أدرج موديول جديد من القائمة Insert ثم الصق الكود ..

حاولت أطبقه على ملفك لكن ملفك يعطيني رسالة خطأ عند محاولة فتحه يرجى رفعه من جديد أخي الكريم

تم تعديل مارس 18, 2015 بواسطه YasserKhalil

حرود · مارس 18, 2015

بارك الله فيك اخي ياسرعلى النصيحة

ياسر خليل أبو البراء · مارس 18, 2015

سجلت لك هذا الفيديو أخي الحبيب

اطلع على رابط الموضوع

http://www.officena.net/ib/index.php?showtopic=59867

حرود · مارس 18, 2015

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

الفاتورة.zip

ياسر خليل أبو البراء · مارس 18, 2015

هل اطلعت على المشاركة رقم 8 ؟

حرود · مارس 18, 2015

نعم اخي اطلعت على المشاركة رقم 8 هل تقصد ان نتبقى الكود في الملف

ياسر خليل أبو البراء · مارس 18, 2015

نعم أخي تبقي الكود في الملف ، لكي تستطيع أن تستخدمه !!

وإلا قد أكون أسأت في فهم سؤالك ..

حرود · مارس 18, 2015

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

بارك الله فيك على صبر معي و نصيحة

تم تعديل مارس 18, 2015 بواسطه حرود

ياسر خليل أبو البراء · مارس 18, 2015

أخي الحبيب : هل أنت عربي ؟؟

أشعر أنك تستخدم جوجل في الترجمة للعربية ؟ لو كنت مجيد للإنجليزية اكتب بالانجليزي ما تريده ..حتى أدرك ما تريده بالضبط

حرود · مارس 18, 2015

انا من المغريب لاجيد سيوة للعربية

**شوقي ربيع** · مارس 18, 2015

السلام عليكم

Sub test()
Dim ws1 As Worksheet: Set ws1 = Sheets("invoice")
Dim ws2 As Worksheet: Set ws2 = Sheets("mat")
Dim lrw1 As Long: lrw1 = ws1.Cells(Rows.Count, "C").End(xlUp).Row
Dim lrw2 As Long: lrw2 = ws2.Cells(Rows.Count, "F").End(xlUp).Row + 1
Dim i As Byte: i = lrw2 - 1 + lrw1 - 9
If ws1.Range("D10") = "" Then Exit Sub
Dim ii As Byte: For ii = lrw2 To i
                ws2.Range("C" & ii).Value = ws1.Range("E3").Value
                ws2.Range("D" & ii).Value = ws1.Range("I3").Value
                ws2.Range("E" & ii).Value = ws1.Range("E5").Value
                ws2.Range("M" & ii).Value = ws1.Range("E7").Value
                Next

ws2.Range("F" & lrw2 & ":L" & i).Value = ws1.Range("D10:J" & lrw1).Value
ws1.Range("C10:J" & lrw1).Value = ""

End Sub

الفاتورة_2.zip

حرود · مارس 18, 2015

اخى شوقي ربيع

اشكرك على الاهتمام

بارك الله فيك

تسجيل الدخول

طلب تعديل كود للترحيل

الردود الموصى بها

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

Important Information