شوقي ربيع

السلام عليكم حسب ماشاهدة في اكوادك فأن الخطاء هو خطاء منطقي حيث انك قبل بداية الحلاقات التكرارية صرحت بأن KH=0 ثم في حدث التنفيذ امرته بالكود Me.Controls.Item(KH + r - 1).Value في هذه الحالة ستكون نتيجة 0 عندما يكون r =1

وهذا كود ثاني اكثر سرعة واختصار Sub test2() Dim sh As Worksheet Dim Lr As Long For i = 1 To 4 Set sh = ThisWorkbook.Sheets("shop" & i) Lr = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 sh.Range("A" & Lr) = Date sh.Range("B" & Lr) = Feuil1.Range("B" & i + 6) sh.Range("C" & Lr) = Feuil1.Range("C" & i + 6) sh.Range("D" & Lr) = Feuil1.Range("D" & i + 6) Feuil1.Range("B" & i + 6) = "" Feuil1.Range("C" & i + 6) = "" Feuil1.Range("D" & i + 6) = "" Next End Sub

تفضل اخي استعمل هذا الكود Sub test() Dim sh As Worksheet Dim Lr As Long Dim T As String For Each sh In ThisWorkbook.Worksheets T = sh.Name For i = 1 To 4 Set sh = ThisWorkbook.Sheets("shop" & i) If T = sh.Name Then Lr = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 sh.Range("A" & Lr) = Date sh.Range("B" & Lr) = Feuil1.Range("B" & i + 6) sh.Range("C" & Lr) = Feuil1.Range("C" & i + 6) sh.Range("D" & Lr) = Feuil1.Range("D" & i + 6) End If Next Next For i = 7 To 10 Feuil1.Range("B" & i) = "" Feuil1.Range("C" & i) = "" Feuil1.Range("D" & i) = "" Next End Sub وهذا المرفق مطبق عليه الكود Data.rar

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

الاخ العزيز قنديل الصياد شكرا جزيلا لمرورك العطر تقبل تحياتي وشكري

جزاك الله خيرا اختي الفاضلة لكلماتك الطيبة ودعواتك تقبلي مني تحياتي وشكري

استادنا القدير كل هدايا الدنيا لاتكفي رد جميل واحد من جميل ابداعاتك شكرا جزيلا لدعاءك الجميل لك مني فائق الاحترام والتقدير

جزاك الله خيرا لعبراتك الجميلة وما أول أعضم الاعمال الا الافكار تقبل تحياتي وشكري

شركرا لمرورك ولدعائك الجميل

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

الف مليون مبروك الترقية الى الامام دائما ان شاء الله

تفضل الملف به المطلوب ارجو ان توضح لي اكثر بخصوص البيانات التي تضاف في صفحات العملاء من الافضل ان ترفق ملف توضيحي اضافة عميل جديد في صفحة جديدة بتنسيق معين 2.rar

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

الاخ jمصطفى كامل اعتذر لردي المتأخر لاني لم ارى ردك الا الان شكرا جزيلا لدعائك الجميل لمرورك العطر تقبل تحياتي وشكري

الاخ jo11 اعتذر لردي المتأخر لاني لم ارى ردك الا الان شكرا جزيلا لمرورك تقبل تحياتي وشكري

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

هذا الملف مجرب وشغال عندي الغياب اليومي.rar

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

أعتذر لعدم ملاحظتي ان الملف فارغ تفضل المرفق rabie.rar

السلام عليكم اضن انه المطلوب حسب فهمي لطلبك الغياب اليومي.rar

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

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

السلام عليكم اجمل شي قابلني اليوم هو ترقيتك اخي الحبيب ضاحي الغريب الف مليون ترليون مبروك الترقية المستحقة عن جدارة وان شائ لله ترقيات اخرى في حياتك العملية مع خالص تحياتي وتقديري اخوك في الله شوقي ربيع

السلام عليكم أعتذر منك اخي لعدم اكمالي معك الموضوع لانقطاع النت عندي وانا الان اكتب هته الاسطر من مقهى انترنت لا علينا سكتب لك الاكواد والشرح الازم ان شاء الله اولا قم بأدراج كومبوبوكس في ورقة العمل ثم ضع هذا الكود في حدث SELECT CHANGE الخاص بالورقة العمال التي انشائت فيها اليست بوكس هذا الكود يجلب السيريلات نمبر من ورقة الدتا بيس دون فرغات الى الكومبو بوكس Dim sh As Worksheet Dim X As Integer Set sh = ThisWorkbook.Sheets("Database") If sh.Cells(Rows.Count, 1).End(xlUp).Row = 1 Then Lr = 2 Else Lr = sh.Cells(Rows.Count, 1).End(xlUp).Row End If Me.ComboBox1.Clear For X = 2 To Lr Me.ComboBox1.AddItem sh.Cells(X, 1) Next ثم في حدث CHANGE الخاص بالكومبوبوكس ضع هذا الكود Dim sh As Worksheet Dim ii As Double Dim Mh As Double Dim Lr As Long Dim X As Integer Set sh = ThisWorkbook.Sheets("Database") Sheet1.Range("B1").Value = Me.ComboBox1.Value ii = Sheet1.Range("B1").Value If ii <> 0 Then With sh Lr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 Mh = WorksheetFunction.Match(ii, .Range("A2:A" & Lr), 0) + 1 End With For X = 1 To 7 Sheet1.Range("B" & X + 3).Value = sh.Cells(Mh, X).Value Next X End If ثم انشاء ميودل وضع فيه هته الاكواد اولا كود اضافت كتاب جديد Sub ajout() Dim sh As Worksheet Dim sh_2 As Worksheet Dim Lr As Long Dim Lr_2 As Long Dim X As Integer Set sh = ThisWorkbook.Sheets("Fourm") Set sh_2 = ThisWorkbook.Sheets("Database") Lr = sh.Cells(Rows.Count, 1).End(xlUp).Row Lr_2 = sh_2.Cells(Rows.Count, 1).End(xlUp).Row + 1 For X = 1 To Lr sh_2.Cells(Lr_2, X).Value = sh.Range("B" & X + 3).Value sh.Range("B" & X + 3) = "" Next X End Sub ملاحظة يمكنك زيادت ماشئت من صفوف في العمد B حيث ان الكود يقوم بترحيل البينات الموجدوة في العمود B ابتداا من الخلية الرابعة الى اخر خلية بها بينات وهذا الكود خاص بالتعديل على البينات Sub Moudf() Dim sh As Worksheet Dim sh_2 As Worksheet Dim Lr As Long Dim Lr_2 As Long Dim ii As Double Dim Mh As Double Dim X As Integer Set sh = ThisWorkbook.Sheets("Fourm") Set sh_2 = ThisWorkbook.Sheets("Database") Lr = sh.Cells(Rows.Count, 1).End(xlUp).Row Lr_2 = sh_2.Cells(Rows.Count, 1).End(xlUp).Row + 1 ii = sh.Range("B4").Value With sh_2 Mh = WorksheetFunction.Match(ii, .Range("A2:A" & Lr_2), 0) + 1 End With For X = 1 To Lr sh_2.Cells(Mh, X).Value = sh.Range("B" & X + 3).Value Next X End Sub يبقى لك التحويل الى التاريخ الهجري والطباعة من الورد سأقوم بادراج الاكواد الازمة متى سنحت لي الفرصة ارجو ان اكون قد وفقت في الشرح تحياتي (شوقي ربيع)

جزاك الله خيرا لعبراتك الجميلة تقبل تحياتي وشكري