أبو عبد الملك السوفي

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

نعم استاذ نقطة التاريخ غفلت عنها ولم انتبه لها ولعلمك استاذ ادخال كود عامل يكون بجهاز الكود بار وانا لم اجرب الكود كع الجهاز وما اقصده عندما تكمل كتابة 13 رقم في الخلية يتم الترحيل قبل ان تكمل كتابة العدد14 مثلا وضعت المؤشر في الخليةa3 وبدأت أكتب كود العامل 1234567891234 لما اكتب الرقم الاخير اريد تفعيل الكود بدون ان اضغط زر انتر الكود يعرف انه انتهت الكتابة في الخلية ويفعل الكود مباشره ارجوا ان اكون قد اوصلت الفكره والمقصود من هذا ان ادخال الارقام يكون بجهز الكود بار فاريد تفعيل الكود دون تدخل بشري

السلام عليكم اساتذتي الكرام هل يوجد او بالاصح هل يمكن عمل كود يعمل عمل زر انتر

اريد كود يعمل كمل انتر الكود الذي سبق الا اذا ضغطت انتر لذا اريد كود يعمل عمل انتر

استاذي الفاضل حاجي جزاك الله كل خير ونفع بك هل لي بطلب آخر استاذي الفاضل

استاذي الفاضل حاجي جزاك الله كل خير ونفع بك

للرفع رفع الله مقامكم في الدنيا والاخره

هل من حل أستاذ حاجي

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

السلام عليكم انا اعمل على برنامج تحضير العمال واريد فكرة عند كتابة 13 رقم في الخلية a3 من صفحة دخول العمال يتم الرحيل مباشرة الى صفحة التجميع دون الحاجة للضغط على ايقونة الترحيل بمعنى اخر عند كتابة 13 رقم في الخلية a3 يتم تفعيل كود الترحيل مباشرة دون تدخل افيدونا جزاكم الله خيرا برنامج مركز شمس للتسوق وتحضير العمال.rar

تمام فرجت عني كربه اسال الله ان يفرج عنك كربة من كرب يوم القيامه هذا هو المطلوب تماما.... اسال الله لك الجنه

جزاك الله خيرا استاذحاجي ونفع بك الهدف من الترحيل الى نفس السطر لان الاستمارة تملأ على مرحلتين المرحلة الاولة تملأ الييانات الاولى في الاستمارة ثم ترحل الى total اما المرحلة الثانية فيتم استدعاء الاستمارة واكمال المعلومات المتبيقة ثم ترحيلها لذا يجب ان تعدل في نفس السطر ولا يتغير مكانها والملف الاخير لم يفي بالغرض فهو ينقل الاستمارة المعدلة الى السطر ما قبل الاخير اي انه يحذف السطر الاخير وهو ليس المطلوب منذ 3 ايام او اكثر وانا احاول في تلك الجزئيه في الكود ولم انجح اخي سابعث لك الملف الاصلي الذي اخذت منه الكود فهو شغال وهو من اعداد الاستاذ محمود لعلك تفهم الية عمل الكود فاتورة جديدة6.rar

للرفع بورك فيكم

السلام عليكم هاته المرة الرابعة التي اطرح الموضوع ولم اجد توجيه او مساعده اعذروني فالامر يتعلق باموال الناس المطلوب هو تعديل الكود Sub Tarheel() 'ÞÑÇÁÉ ÇáÈíÇäÇÊ ÇáÎãÓÉ ÇáÃæáí Dim d(19) d(1) = [g6]: d(2) = [g2]: d(3) = [g3]: d(4) = [g4]: d(5) = [b8]: d(6) = [g8]: d(7) = [C13]: d(8) = [f13]: d(9) = [C18]: d(10) = [f19]: d(11) = [C20]: d(12) = [b23]: d(13) = [B26]: d(14) = [c26]: d(15) = [B27]: d(16) = [c27]: d(17) = [b28]: d(18) = [c28]: d(19) = [c30] ' Check if this Invoice is exist With Sheets("total") LR = .[b10000].End(xlUp).Row For r = 4 To LR x = .Cells(r, 2).Value If x = [g6] Then GoTo 10 ' *** Found @ r (Row)*** Next r GoTo 30 ' NOT Found 10 MsgBox ("ÇáÝÇÊæÑÉ ãæÌæÏÉ ãä ÞÈá" & Chr(10) & "ÓíÊã ÍÐÝåÇ ãä æÑÞÉ ÇáÈíÇäÇÊ æäÞáåÇ ãßÇä ÇáÞÏíãÉ") If r <> LR Then n_LR = .Cells(r, 2).End(xlDown).Row - 1: GoTo 20 n_LR = .[b10000].End(xlUp).Row 20 .Range("B" & r & ":G" & n_LR).EntireRow.Delete Shift:=xlUp 30 'äÞá ÇáÈíÇäÇÊ ÇáÎãÓÉ ÇáÃæáí ááæÑÞÉ ÏÇÊÇ DR = .[b10000].End(xlUp).Row + 1 'ÂÎÑ ÕÝ ÈíÇäÇÊ ÌÇåÒ áÇÓÊáÇã ÈíÇäÇÊ ÌÏíÏÉ ÈÇáæÑÞÉ ÏÇÊÇ For i = 1 To 19 .Cells(DR, i + 1) = d(i) Next i End With LR = [E31].End(xlUp).Row 'ÞÑÇÁÉ æäÞá ÇáÈíÇäÇÊ ÇáÃÑÈÚÉ ÇáÃÎíÑÉ Sheets("mokalassa").Select Reply = MsgBox("Êã ÊÑÍíá ÇáÝÇÊæÑÉ ÈÍãÏ Çááå" & Chr(10) & "åá ÊÑíÏ ãÓÍ ÇáÈíÇäÇÊ ãäåÇ", vbYesNo) If Reply <> 6 Then Exit Sub Range("g2") = [g3] Range("g3") = "=NOW()" Range("g4") = "=IF(HOUR(R[-1]C)>15,""ÇáãÓÇÆíÉ"",""ÇáÕÈÇÍíÉ"")" Range("b8:e8").ClearContents Range("g8").ClearContents Range("c13:d13").ClearContents Range("f13:g13").ClearContents Range("c18:d18").ClearContents Range("f19:g19").ClearContents Range("c20:d20").ClearContents [g6] = [g6] + 1 Range("b26:b28").ClearContents Range("c26:g26").ClearContents Range("c27:g27").ClearContents Range("c28:g28").ClearContents Range("c30:d30") = "=IF(R[-10]C="""","""",(R[-2]C[-1]+R[-3]C[-1]+R[-4]C[-1]+R[-10]C)-(R[-12]C+R[-17]C))" Range("b23:c23") = "=IF(R[-3]C[1]="""","""",R[-3]C[1]-(R[-5]C[1]+R[-10]C[1]))" End Sub فعند الرحيل اذا كان رقم الاستمارة موجود من قبل في صفحة total فانه يرحل الى نفس السطر وليس الى اخر سطر واضن ان الجزئية التاليه هي المقصودة بالتعديل 10 MsgBox ("الفاتورة موجودة من قبل" & Chr(10) & "سيتم حذفها من وقة البيانت ونقلها من مكانها القديم") If r <> LR Then n_LR = .Cells(r, 2).End(xlDown).Row - 1: GoTo 20 n_LR = .[b10000].End(xlUp).Row 20 .Range("B" & r & ":G" & n_LR).EntireRow.Delete Shift:=xlUp برنامج مركز شمس للتسوق تحت التعديل.rar

فضلكم هل من رد أضن أن الامر ليس بهاته الصعوبة على عمالقة المنتدى للرفع رفع الله قدركم

أبلغ فريق الموقع عن مخالفة قام بنشر منذ 18 ساعات السلام عليكم جزاكم الله كل خير ونفع بكم من فضلكم اريد تعديل الكود التالي Sub kh_trheel2014() On Error Resume Next Dim Ary Dim M As Long, Mt As Long Dim Txt As String Txt = [C14] & [C8] & [C9] & [D10] & [G10] & [C12] With shit4 M = .Cells(.Rows.Count, "A").End(xlUp).Row Mt = WorksheetFunction.Match(Txt, .Range("L2").Resize(M), 0) If Mt Then If MsgBox("تم تويق البيانات من قبل " & vbCr & "هل تريد مواصلة التوثيق", vbYesNo, "تأكيد") = vbNo Then GoTo 1 End If Ary = Array(M, [C14], [C8], [C9], [D10], [G10], [C12], [F14], [G5] & [H5] & [I5], [D18], [G16], Txt) .Cells(M + 1, 1).Resize(1, 12).Value = Ary MsgBox ("شكرا تم التويق") Range("C8:I8").ClearContents Range("C9:I9").ClearContents Range("D10:E10").ClearContents Range("G10:I10").ClearContents Range("C12:I12").ClearContents Range("C14:D14").ClearContents Range("F14:I14").ClearContents Range("D18:I18").ClearContents End With 1: End Sub والتغيير المطلوب هو عندما تكون نفس البيانات اريد من الكود ان يحفظ البيانات الجديدة في نفس المكان ولا يرحلها الى آخر سطر برنامج رشيد للشهادت المدرسية1.rar

ألا هل من مجيب جزاكم الله خيرا

السلام عليكم جزاكم الله كل خير ونفع بكم من فضلكم اريد تعديل الكود التالي Sub kh_trheel2014() On Error Resume Next Dim Ary Dim M As Long, Mt As Long Dim Txt As String Txt = [C14] & [C8] & [C9] & [D10] & [G10] & [C12] With shit4 M = .Cells(.Rows.Count, "A").End(xlUp).Row Mt = WorksheetFunction.Match(Txt, .Range("L2").Resize(M), 0) If Mt Then If MsgBox("تم تويق البيانات من قبل " & vbCr & "هل تريد مواصلة التوثيق", vbYesNo, "تأكيد") = vbNo Then GoTo 1 End If Ary = Array(M, [C14], [C8], [C9], [D10], [G10], [C12], [F14], [G5] & [H5] & [I5], [D18], [G16], Txt) .Cells(M + 1, 1).Resize(1, 12).Value = Ary MsgBox ("شكرا تم التويق") Range("C8:I8").ClearContents Range("C9:I9").ClearContents Range("D10:E10").ClearContents Range("G10:I10").ClearContents Range("C12:I12").ClearContents Range("C14:D14").ClearContents Range("F14:I14").ClearContents Range("D18:I18").ClearContents End With 1: End Sub والتغيير المطلوب هو عندما تكون نفس البيانات اريد من الكود ان يحفظ البيانات الجديدة في نفس المكان ولا يرحلها الى آخر سطر

السلام عليكم عندي كود بعد ان يرحل يمسح محتويات الخلايا وهذا امر المسح Range("b8:e8").ClearContents واريد منه بدل المسح ان يكتب في الخلية دالة معينة مثلا جمع ماذا افعل جزاكم الله كل خير استطعت التغلب عن الامر جزاكم الله كل خير استطعت التغلب على الامر جزاكم الله خيرا استطعت التغلب على الامر

للرفع رفع الله مقامكم

للرفع جزاكم الله

للرقع

هذا مرفق به مثال برنامج المخالصة2017_2.rar

جزاك الله خيرا ونفع بك

السلام عليكم اسات\تنا الكرام هذا الكود من احد اساتذة المنتى جزاه الله خيرا لكن اريد ان اعدله بحث عند الترحيل ا\ا كانت الاستمارة موجودة من قبل في شيت total يرحل الاستمارة الى نفس المكان Sub Tarheel() 'ÞÑÇÁÉ ÇáÈíÇäÇÊ ÇáÎãÓÉ ÇáÃæáí Dim d(17) d(1) = [g2]: d(2) = [g3]: d(3) = [g4]: d(4) = [b8]: d(5) = [g8]: d(6) = [c13]: d(7) = [f13]: d(8) = [c18]: d(9) = [f19]: d(10) = [c20]: d(11) = [b23]: d(12) = [b26]: d(13) = [c26]: d(14) = [b27]: d(15) = [c27]: d(16) = [b28]: d(17) = [c28] 'äÞá ÇáÈíÇäÇÊ ÇáÎãÓÉ ÇáÃæáí ááæÑÞÉ ÏÇÊÇ With Sheets("total") LR = .[a10000].End(xlUp).Row For r = 1 To LR x = .Cells(r, 1).Value If x = [v6] Then GoTo 20 ' *** Found @ r (Row)*** Next r GoTo 10 ' NOT Found 10 MsgBox ("ÇáÝÇÊæÑÉ ãæÌæÏÉ ãä ÞÈá" & Chr(10) & "ÓíÊã ÍÐÝåÇ ãä æÑÞÉ ÇáÈíÇäÇÊ æäÞáåÇ Åáí ÂÎÑ ÇáæÑÞÉ") If r <> LR Then n_LR = .Cells(r, 2).End(xlDown).Row - 1: GoTo 20 n_LR = .[i10000].End(xlUp).Row 20 .Range("a" & r & ":u" & n_LR).EntireRow.Delete Shift:=xlUp 30 'äÞá ÇáÈíÇäÇÊ ÇáÎãÓÉ ÇáÃæáí ááæÑÞÉ ÏÇÊÇ DR = .[b10000].End(xlUp).Row + 1 'ÂÎÑ ÕÝ ÈíÇäÇÊ ÌÇåÒ áÇÓÊáÇã ÈíÇäÇÊ ÌÏíÏÉ ÈÇáæÑÞÉ ÏÇÊÇ For i = 1 To 17 .Cells(DR, i + 1) = d(i) Next i End With LR = [E30].End(xlUp).Row Sheets("mokalassa").Select Reply = MsgBox("Êã ÊÑÍíá ÇáÝÇÊæÑÉ ÈÍãÏ Çááå" & Chr(10) & "åá ÊÑíÏ ãÓÍ ÇáÈíÇäÇÊ ãäåÇ", vbYesNo) If Reply <> 6 Then Exit Sub Range("G2").ClearContents Range("G3").ClearContents Range("G4").ClearContents Range("b8:e8").ClearContents Range("g8").ClearContents Range("c13:d13").ClearContents Range("f13:g13").ClearContents Range("c18:d18").ClearContents Range("f19:g19").ClearContents Range("c20:d20").ClearContents Range("b23:c23").ClearContents [g6] = [g6] + 1 Range("b26:b28").ClearContents Range("c26:g26").ClearContents Range("c27:g27").ClearContents Range("c28:g28").ClearContents End Sub ولا ينقلها الى اخر سطر برنامج المخالصة2017.rar