نجوم المشاركات

ربما كود بهذا الشكل يفي بالغرض Sub Test() If Range("A1").Value = "No" Then Range("B1").ClearContents End Sub

استبدل الكود السابق بهذا الكود Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub If Not Intersect(Target, Range("D6:D115")) Is Nothing Then If Target.Value = 4 Then Target.Offset(, 2).ClearContents End If End Sub

اخى الكريم يمكن جعل الكود ينشط تلقائى عند تغير قيمة الخلية المرادة هنا D5 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub If Target.Address = "$D$5" Then If Target.Value = 4 Then Range("F5").ClearContents End If End Sub جرب المرفق مسح محتوى_2.rar

الأخ الكريم يرجى تغيير اسم الظهور للغة العربية .. راجع موضوع التوجيهات في الموضوعات المثبتة في المنتدى إليك الملف التالي تصنيف.rar

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته بعد الاتفاق مع الاخ سيف الدين وردنا على استئذان اخونا / megonil ونقول له ان نحن اسرة واحدة مكملين لبعضنا البعض وقد بادرت بجمع الملفين مع بعض واضفت بعض الميزات الجديدة وهي : 1- شاشة دخول وخروج مع اخفاء القوائم واشرطة الادوات وامكانية الحفظ والخروج واظهار القوائم واشرطة الادوات 2 - وضعت الاستعاذة والبسملة قبل بدء البرنامج 3 - تنبيه (اثناء البحث وفي حالة انك لم تضع كلمة البحث وضغطت زر بحث) 4 - تنبيه (اثناء البحث وفي حالة عدم ظهور نتائج للبحث ) 5 - تلوين الكلمة هدف البحث باللون الأحمر اثناء رؤيتها في الملف وفي الاستخدام مايغني عن الشرح تفضلوا المرفق ولا تنسوا الدعاء لكل من ساهم في هذا الملف ودمتم في حفظ الله وسلامته تحياتي وسلامي اخوكم/ خبور _____________________.rar

الحمد لله الملك الحق المبين ، الذي هدانا إلى الإيمان واليقين ، وقال {وَوَصَّى بِهَا إِبْرَاهِيمُ بَنِيهِ وَيَعْقُوبُ يَا بَنِيَّ إِنَّ اللّهَ اصْطَفَى لَكُمُ الدِّينَ فَلاَ تَمُوتُنَّ إَلاَّ وَأَنتُم مُّسْلِمُونَ} نحمده تعالى وهو الرب الجليل ، الهادي إلى سواء السبيل ، الذي لا يخفى عليه الكثير ولا القليل ، وأشهد أن لا إله إلا الله وحده لا شريك له أمر بإتباع الحق ونهى عن إتباع الباطل ، ورفع من شأن العالم دون الجاهل ، وأشهد أن سيدنا محمداً عبده ورسوله جاء بالحق المبين ، فكان رحمة للعالمين ، صلى الله عليه وعلى آله واصحابه وسلم تسليماً كثيراً . طلب مني أحد الأخوة تطوير برنامج الشيكات الإصدار الأول الذي تم طرحه مسبقا علي الرابط وبحمد الله تم اضافة بعض وظائف البرنامج وشاشة تقارير حسب جهة الصرف او بين تاريخين مع الطباعة وتم تعديل الشيك حسب قرار وزارة المالية كما ورد بطلب الاخ الكريم شرح مبسط للفورم الملف بالمرفقات الشيكات الأصدار الثاني.rar

برنامج المخزون و الفواتير الشامل .... الاصدار الثالث اكسيل 2007 - اكسيل 2010 اليوم بمشيئة الله هو الانطلاق الرسمى لهذة النسخه وبعد انتهاء مرحلة التجربة التى دامت اكثر من شهرين خطوات استخدام البرنامج لأول مره تسجيل البيانات الجديدة داخل البرنامج لعمل فواتير البيع و الشراء و الحركات المالية 1- تسجيل اسماء مناديب البيع وهى خطوه مهمه مطلوبة لتسجيل اسم عميل جديد 2- تسجيل و ادخال العملاء (يتم ربط كل عميل باسم مندوب) 3- تسجيل و ادخال الموردين 4- تسجيل و ادخال اسماء لفئة الصنف وهى خطوه مهمه مطلوبة لتسجيل صنف جديد 5- تسجيل و ادخال الاصناف (ولابد من وجود فئة مدخله مسبقا لكى تستطيع ادخال الصنف) 6- ولا تنسى تسجيل رصيد اول المده فى شاشة البيانات و الجرد الجديد فى هذا الاصدار * واجهة تطبيقية كاملة * برنامج كامل مخزون فواتير ذمم عملاء وموردين واستحقاقات خلال الفترات الزمنية المختلفة * اختصارات سريعة لتنفيذ العمليات و التقارير بسرعة عالية * كشف حساب بطريقة جديدة بمعنى نفترض انه هناك عميل ما علية مديونية بفيمة 15000 فالبرنامج يعطيك كشف حساب تفصيلى للمديونية المستحقة خلال فترات 30 يوم 60 يوم 90 يوم و اكثر من 90 يوم فمثلا فى المثال السابق يكون استحقاق المديونية على حسب فواتير العميل مستحق فى 30 يوم 3000 وفى 60 يوم 6000 وفى 90 يوم 4000 و فى اكثر من 90 يوم 2000 فيكون اجمالى المديونية هم ال 15000 لكن الاستحقاق فى فترات مختلفه وهذا الكشف يفيد كل من يتعامل بالاجل لمعرفة المستحق خلال الفترة التى يريدها وعندما يقوم العميل بسداد جزء من المستحق يتم خصمه من المديونية القديمه بمعنى ان العميل فى المثال السابق قد قام بسداد 1500 فيتم خصمها من ال 2000 وهى مديونية الاكثر من 90 فيصبح كشف حسابة كالتالى مستحق فى 30 يوم 3000 وفى 60 يوم 6000 وفى 90 يوم 4000 وفى اكثر من 90 يوم 1500 فيكون اجمالى المديونية هم ال 13500 * شاشة فواتير جديده تحوى الكثير و الكثير من الاختصارات للعملاء و الاصناف وتوصلك الى عدة تقارير بضغطة زر واحده عرض معلومات عن الصنف و رصيده الحالى داخل المستودع و اخر سعر شراء بمجرد اختيارك للصنف وادخاله داخلة الفاتوره سهولة الغاء وتعديل الصنف داخل الفاتورة عن طريق الدبل كليك ذهاب مباشره الى تقرير صنف معين بمجرد اختياره وضغط تقرير الصنف اكتشف المزيد............ *شاشة لتقرير المديونية خلال الفترات الزمنية المختلفة يجب عليك قراءة ومراجعة شرح البرنامج جيدا حيث توجد العديد و العديد من الاختصارات السريعة التي تنقلك من شاشة الى اخرى بسرعه عالية ولتوفير وقتك داخل البرنامج. كما توفر لك سرعة الحصول على المعلومة المطلوبة. * لتحميل نسخة من الشرح وهى عبارة عن ملف تنفيذي اضغط على الرابط التالى شرح برنامج المخزون و الفواتير الشامل( ملف تنفيذى... 6MB رابط خارجى على موقع ميديا فاير) * او الذهاب الى موضوع شرح البرنامج و مناقشات مشرفى و اعضاء المنتدى داخل المنتدى على الرابط التالى شرح برنامج المخزون و الفواتير الشامل(مشاركة داخل المنتدى) كما احببت ان اقدم مناقشة ونصائح مديري و اعضاء المنتدى للبرنامج لكى يستفيد منها الجميع وهذه المواضيع تم مناقشتها في موضوع شرح البرنامج داخل المنتدى انظر المشاركة التالية لمشاهدة النصائح و المناقشات حول البرنامج واخيرا اقدم لكم البرنامج حجم البرنامج 1.2 MB اختر اسم المستخدم المدير كلمة السر 123 محرر الاكواد 85211 لاتترد فى الاستفسار عن اى شيى داخل البرنامج ضع مشاركتك وسوف يتم الرد عليها كما يمكن مراسلتى على الايميل التالى amroomo@gmail.com اخيرا اتمنى ان يكون هذا البرنامج اضافة الى برامج المخزون و الفواتير وتغيير مسارها على الاكسيل فهذا العمل جديد بكل المقاييس فى افكاره التى اتمنى ان اكون قدمتها بصورة جيدة ويستقيد بها الجميع وَقُلْ رَبِّ زِدْنِي عِلْمًا ========================================================= المرفق المحدث الاخير: SIS 3.152 (Add City).rar

طريقة عمل شاشة ( فورم ) ادخال وترحيل واستعلام وتعديل !! خطوة خطوة السلام عليكم اساتذة المنتدي وخبراؤه الكبار الاخوة الافاضل اعلم ان هذه الموضوعات قد قتلت بحثا وطلبا واجابة من الاعضاء وهناك امثلة كثيرة للاساتذة الافاضل الكبار والذي لايصل علمنا او ما لدينا كله الي ذرة واحدة من علمهم ولكني اردت ان اجعل المواضيع الاساسية في عمل اي برنامج في متناول الجميع بطريقة بسيطة وسهله اكثر ما يكون من خلال هذه السلسلة ( اعانني الله علي اكمالها كما ينبغي ) وقصدت ان يكون الموضوع بعنوان واضح ليستفيد منه الجميع عند البحث وسأقدم الشرح بطريقة الفيديو والاكسيل والورد احياناً (((( الدرس الاول )))) شاشة ( فورم ) لادخال بيانات والقيام بتسجيل وترحيل هذه البيانات الي صفحة الاكسيل و الاستعلام من خلالها عن طريق نفس الفورم والتعديل ايضا في البيانات في حالة ما اردنا التعديل في بيان قد سبق ادخاله وطبعاً والاكيد كله من علمكم اساتذتي الكرام الاجلاء وفي الدرس القادم سنتعرف علي بعض الاكواد المعاونة لشاشة الادخال او بمعني ادق اكواد نحتاجها مع شاشة الادخال مثل (تنسيق التكست بوكس ، الترقيم التلقائي في تكست معين ، تنسيق التاريخ في التكست بوكس .... ) واي استفسار .... في الخدمة دائما ... واي شئ غير واضح في الشرح علي استعداد تام لشرحه مرة اخري ومرات اخري واليكم ايضا في المرفقات : 1- ملف اكسيل به الاكواد والشرح هذه المرة داخل الكود ( تم شرح الكود سطر سطر بطريقة وافية وبسيطة جدا داخل الكود نفسه ) 2- عدد ( 3 ) ملف فيديو يشرح طريقة التصميم واضافة الاكواد وكذلك مشاهدة النتيجة جزاكم الله خيرا اساتذتنا اكسيل ..طريقة عمل شاشة ادخال 1.rar فيديو 1 .. طريقة عمل شاشة ادخال 1.rar الملف الفيديو الثاني والثالث في المشاركة التالية حيث لم يمكنني اضافتهم هنا

بسم الله الرحمن الرحيم الاخوة والاخوات فى هذا الصرح العظيم أقدم لكم اليوم الاصدار الثالث من برنامج EMA يشمل جميع الامور المحاسبيه هذه النسخه نسخه تجريبيه يرجى من الاخوة المحاسبين والمهتمين بالامور المحاسبية التجربه والتقييم للوصول الى الافضل ان شاء الله بنزل الشرح عن كيفية الاستخدام والتعامل مع البرنامج اى سؤال أو استفسار لا تترد وأنا تحت امركم كلمة المرور - الدعم الفني الباسورد - 123 تفضل نسختك EMA.zip

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

بالنسبة للطلب الأول جربي الكود التالي Sub SequenceAllSheets() Dim SH As Worksheet, LR As Long For Each SH In Worksheets With SH LR = .Cells(Rows.Count, "C").End(xlUp).Row If .Cells(LR, "C") = "جمـــلة " Then LR = LR - 1 With .Range("A4:A" & LR) .NumberFormat = "General" .Formula = "=ROW()-3": .Value = .Value End With End With Next SH End Sub الطلب الثاني يخصص له موضوع مستقل

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

الاخت الفاضلة صحيح انك قد وضحتى المطلوب تماما ولكن لم تذكرى حدث تنفيذ الكود .. اى .. كيف ينفذ الكود .. من خلال زر امر ام عند تنشيط الصفحة الكود المستخدم فى الترتيب استناداً الى عدم فراغ خلايا العمود C وينفذ عند تنشيط الصفحة عموماً اليكى الملف التالى وابدى ملاحظاتك ع بنات اغسطس 555_3.rar

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

بعد اذن اخي نور الدين انت تحاول ان تعديل حقل مصدره استعلام غير قابل للتحديث بناء على الربط الموجود ! تفضل هذا الكود : Private Sub pur_price1_AfterUpdate() '[pur_price] = [pur_price1] DoCmd.RunSQL "update items set pur_price=" & pur_price1 & " where item_code=" & item_code1 End Sub بالتوفيق

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

اخى الكريم هذا هو عمل الكود السابق !!!!!! - وعن الاخفاء فقط ضع هذا السطر فى نهاية كود ترحيل الفاتورة ومسح بياناتها Range("C10:J60").Borders.LineStyle = xlNone اما وان اردت كود يقوم باضافة تسطير حال اضافة قيمة الى العمود E ومسح التسطير حال حذف تلك القيمة Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.Count > 1 Then Exit Sub If Not Intersect(Target, Range("E10:E60")) Is Nothing Then If Target.Value <> "" Then Target.Offset(0, -2).Resize(1, 8).Borders.LineStyle = xlDot Else Target.Offset(0, -2).Resize(1, 8).Borders.LineStyle = xlNone End If End If End Sub

اخى الكريم استبدل الكود السايق بهذا الكود Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.Count > 1 Then Exit Sub If Not Intersect(Target, Range("E10:E60")) Is Nothing Then With Target.Offset(0, -2).Resize(1, 8) .Borders.LineStyle = xlDot End With End If End Sub اما وعن ازالة التسطير عند افراغ الخلايا الافضل ..ان يكون هذا الامر فى حدث ترحيل الفاتورة وافراغ بياناتها .... من خلال اضافة الكود التالى Range("C10:J60").Borders.LineStyle = xlNone تقبل تحياتى

بسم الله والصلاة والسلام على رسول الله وعلى آله وصحبه ومن والاه أما بعد: السلام عليكم ورحمة الله وبركاته... مباركة عليكم عودة المنتدى إلى سابق عهده...أما من حيث دراستنا هذه فإنني أعتبر أن هذه ليست نهاية المطاف فبإمكان أي من إخوتي الأكارم تعويض النقص وسد الخلل وإتمام البحث الذي أقف شخصياً - لقلة علمي فقط - عاجزاً معتذراً...شاكراً لكل من ساهم ...متمنياً عليكم إيفاءه حقه لأكون طالباً أجثو على ركبتي مستلهماً من علمكم الفياض مستنيراً بقبس من نوركم فهلا أكملتم المشوار. والصلاة والسلام على سيد المرسلين والحمد لله رب العالمين أخوكم المحب لكم أبو يوسف.

P السلام عليكم ورحمة الله وبركاته... بعد أن تجاوزنا بفضل الله تعالى ومنته البحث – حسب المستطاع – باتجاهيه الكتابة والترحيل ثم البحث والتعديل نقوم بعرض الأزرار التي تهتم بالنموذج كما في الصورة أدناه حيث سنستعرضها حسب موقعها من النموذج من اليمين إلى اليسار: 1 – مسح جميع البيانات CmbClearSheet1:حيث يقوم الزر بالضغط عليه بمسح البيانات من الورقة DATA للبدء بورقة جديدة خالية من البيانات التي تم تحميلها إليها بعد عرض رسالة للسماح جميع البيانات : Private Sub CmbClearSheet1_Click() Clear_Sheet1 End Sub بعد إعطاء الزر الأمر بالمسح لبيانات سندات الصرف ننتقل إلى الكود التالي حيث سيتم اختيار النطاق من A9 حتى I1000 تظهر الرسالة وعند توكيدها بالموافقة يتم مسح المحتويات أما إن ضغطت على الزر لا سيتم التراجع عن قرارك السابق بالمسح ولا تمس بياناتك. Sub Clear_Sheet1() Dim Msg As String Dim Amr As Integer With sheet1 .Activate .[A9:I1000].Select Msg = " هل انت متأكد من مسح جميع بيانات سندات الصرف " Amr = MsgBox(Msg, vbYesNo) If Amr = vbYes Then Selection.ClearContents End If Range("A9").Select End With End Sub 2- مسح الفورم: CmdClear وهنا يقوم بمسح البيانات التي دوّنت على النموذج كما هو موضّح أدناه: Private Sub CmdClear_Click() Clear End Sub 3- زر طباعة: CmdPrintعندما تريد طباعة سند تم تصميم عرض وارتفاع وهوامش المستند على جانبيه الأيمن والأيسر."يرجى التداخل لشرح هذا الكود".. Private Sub CmdPrint_Click() On Error GoTo 0 If CmdSearch.Text = "" Then MsgBox "من فضلك أدخل رقم السند", vbOKOnly, "طباعة خطأ!" Exit Sub Else Frame6.Visible = False Frame11.Visible = False 'TextBox1.ShowDropButtonWhen = 0 Toumana.Zoom = (Toumana.Zoom * 1) Toumana.Width = (Toumana.Width * 1) Toumana.Height = (Toumana.Height * 1.1) Toumana.Left = 200: Toumana.Top = 30 Toumana.PrintForm End If Call RestForm 0 End Sub 4- التعديل: وهنا التعديل على بيانات النموذج: CmdEdit Private Sub CmdEdit_Click() Amendment End Sub 5- إغلاق: وهنا يتم إغلاق النموذج فتدخل إلى ورقة البيانات... Private Sub CmdExit_Click() On Error GoTo 1 Application.Visible = True sheet1.Activate Unload Me 1 End Sub 6- حفظ وخروج:يتم حفظ البيانات ثم الخروج من التطبيق: Private Sub CommandButton1_Click() Me.Hide ActiveWorkbook.Save Workbooks.Application.Quit End Sub كما أننا نلاحظ أن النموذج يطالبك بملء البيانات المطلوبة كاملة قبل الحفظ والطباعة فعندما تضع البيانات عدا المبلغ تطالبك رسالة بإدخال المبلغ، وكذلك الاسم ثم سبب الصرف حسب تسلسل الخطأ قبل الترحيل أي:( لا يتم ترحيل البيانات إلا إذا كانت متكاملة ضمن حقول النموذج): Sub AddNew() Dim Msg As String Dim Amr As Integer Dim totalrows As Long Dim str As String On Error GoTo 1 If TxAmount.Text = "" Then MsgBox "من فضلك ادخل المبلغ", vbOKOnly, "المبلغ خطأ!" Exit Sub End If If TxName.Text = "" Then MsgBox "من فضلك ادخل الأسم", vbOKOnly, "الأسم خطأ!" Exit Sub End If If TxDescription.Text = "" Then MsgBox "من فضلك ادخل سبب الصرف", vbOKOnly, "الوصف خطأ!" Exit Sub End If If ChChaqe.Value = False And ChCash.Value = False Then MsgBox "من فضلك أختار طريقة الصرف ", vbOKOnly, "الصرف!" Exit Sub ElseIf ChChaqe.Value = True And TxChNo.Text = "" Then MsgBox "من فضلك أدخل رقم الشيك ", vbOKOnly, "رقم الشيك!" Exit Sub ElseIf ChChaqe.Value = True And TxChDate.Text = "" Then MsgBox "من فضلك أدخل تاريخ الشيك ", vbOKOnly, "تاريخ الشيك!" Exit Sub ElseIf ChChaqe.Value = True And TxChBank.Text = "" Then MsgBox "من فضلك أدخل البنك ", vbOKOnly, "البنك!" Exit Sub End If totalrows = sheet1.Cells(Rows.Count, "A").End(xlUp).Row If totalrows < 8 Then totalrows = 8 Else totalrows = totalrows End If sheet1.Cells(totalrows + 1, 1) = Format(TxNo.Text, "0") sheet1.Cells(totalrows + 1, 2) = Format(TxDate.Text, "yyyy/mm/dd") sheet1.Cells(totalrows + 1, 3) = TxName.Text sheet1.Cells(totalrows + 1, 4) = TxDescription.Text If ChCash.Value = True Then sheet1.Cells(totalrows + 1, 5) = Format(TxAmount.Text, "0") ElseIf ChChaqe.Value = True Then sheet1.Cells(totalrows + 1, 8) = Format(TxAmount.Text, "0") sheet1.Cells(totalrows + 1, 6) = Format(TxChNo.Text, "0") sheet1.Cells(totalrows + 1, 7) = Format(TxChDate.Text, "yyyy/mm/dd") sheet1.Cells(totalrows + 1, 9) = Format(TxChBank.Text, "0") End If MsgBox "تم ترحيل وحفظ السند بنجاح" 'Sheet1.Range("A9:I" & totalrows + 1).Sort Key1:=Sheet1.Range("A9"), Order1:=xlAscending Msg = "هل تريد طباعة السند" Amr = MsgBox(Msg, vbYesNo) If Amr = vbYes Then ChCmdSearch.Value = True CmdSearch.Text = TxNo.Value CmdPrint_Click End If Clear m = sheet1.[M9] mm = 9 Do Until sheet1.Cells(mm, "a").Text = "" mm = mm + 1 Loop TxNo.Value = mm + 1 - 10 + m 1 End Sub وأخيراً أقول لأستاذي الكريم ضاحي الغريب وإخوتي الذين شاركوني إياه جزاكم الله خيراً وبالنسبة لي هذا الجهد المستطاع والجود من الموجود وفقني الله وإياكم لما يحب ويرضي وجعلنا من أهل البر والتقوى...آمين . أعتذر إليك أستاذي الكريم ضاحي الغريب فالموضوع أكبر من حجمي وتصوري وأعلم أنه لا زال الكثير منه لم نتطرق له أو أنني قد أخطأت في تفسير كود ما أو أكثر وذلك لقلة خبرتي ودرايتي.. والحمد لله الذي بنعمته تتم الصالحات والصلاة والسلام على سيد المرسلين والحمد لله رب العالمين أخوكم المحب لكم أبو يوسف.

جزاكم الله خير الأستاذ العزيز / خالد الرشيدي على صدركم الرحب وأخلاقكم الرائعة أم التعديل أجده أمر عادي ربما مجرد سهو منكم وإلا فأنتم أجدر بما هو أكبر من ذلك بارك الله فيكم ورفع قدركم

السلام عليكم و رحمة الله و بركاته أتمنى أن تكون و جميع أعضاء منتدى أوفيسنا بألف خير عودة ميمونة و موفّقة بإذن الله .. إشتقنا لكم و الله بارك الله فيك أستاذنا القدير محمد حسن المحمد على مواضيعك الشيّقة ..جزاك الله خيرًا و زادها بميزان حسناتك ..

P السلام عليكم ورحمة الله وبركاته... أما من حيث البحث برقم السند فإنني أرجو من الإخوة الكرام التفضل بعرض كوده وشرح مؤداه علماً أنني وجدت هذا الكود يتمحور حول هذا المجال...تاركاً لكم التوسع بشرحه Private Sub CmdSearch_Change() D_Search End Sub أما الحقول التي تعرض بشكل افتراضي أسماء المستلم والمحاسب والمدير هي عبارة عن TextBox أطلق اسم TDebtor على الخاص بالمدير وحقول التعريف بجهة إصدار السند،وقد صمم كوداً لتظهر الأسماء المسجلة في ورقة العمل DATA كما يلي: Private Sub TDebtor_Change() End Sub Private Sub UserForm_Initialize() '''''''''''''''''''''''''''''''''''''''''''''''''''''' m = sheet1.[M9] mm = 9 Do Until sheet1.Cells(mm, "a").Text = "" mm = mm + 1 Loop TxNo.Value = mm + 1 - 10 + m TxDate.Text = Format(Date, "yyyy/mm/dd") ChCmdSearch.Value = True TxNo.Locked = True CombNames.Visible = False Cmbabout.Visible = False TextBox5.Value = sheet1.[m2] TextBox4.Value = sheet1.[m3] TextBox3.Value = sheet1.[m4] TDebtor.Value = sheet1.[m6] LaST.Caption = sheet1.[m7] LaTe.Caption = sheet1.[m8] End Sub تم عرض تاريخ تحرير السند وهنا تم إعداد مربعات نصوص مساوية لما يقابلها من نصوص في العمود حيث الخلية كما يلي: أسم الشركة شركة اوفيسنا التعليمية M2 TextBox5 المستلم خالد خليل M3 TextBox4 المحاسب ضاحي الغريب M4 TextBox3 المدير خبور خير M6 TDebtor عنوان الشركة شركة أوفيسنا التعليمية - ميدان أوفيسنا - شارع 10 M7 LaST تليفونات وايميل وفاكس ت : 322145678 فاكس :- 325641471 M8 LaTe وبذلك أكون قد عرضت القسم الثاني من البحث بما أمدني الله ...وتركت لإخوتي الكرام التفضل بشرح ما لم يدركه علمي الضحل ...فهم أجدر بذلك وأقدر عليه؟ والصلاة والسلام على سيد المرسلين والحمد لله رب العالمين. والسلام عليكم ورحمة الله وبركاته... أخوكم المحب لكم أبو يوسف يتبع إن شاء الله تعالى....

أخي العزيزالأستاذ / خالد الرشيدي جزاك الله خير وكما أشار استاذن الكبير / ياسر خليل أسلوبك في المعادلات رهيب فعلا فقد لاحظت ذلك في بعض ردودك زادك الله علما ورفعة أحببت أن استفسر حول استخدام دالة ( INDIRECT ) مع دالة ( SUMIF ) لماذا لم تستخدم نفس المدى الذي استخدمته مع دالة (COUNTIF) وهو: $C$7:C7 فاظنه يعطي نفس النتيجة وقد جربت التعديل في المعادلة فأدت نفس النتيجة وتركيب المعادلة هو =IF(COUNTIF(C$7:C7;C7)>1;SUMIF($C$7:C7;C7;$I$7:$I$489);I7) هذا والله أعلم بارك الله فيكم الأستاذ العزيز / خالد الرشيدي وجزاكم الله خير ومنتظرين المزيد من إبدعاتكم تقبل تحياتي وتقديري والعفو

أخي الحبيب ياسر فتحي إليك الكود التالي عله يفي بالغرض بالنسبة لملفك في المشاركة الأولى قمت بإزالة التنسيقات في الأعمدة والصفوف الزائدة ...لا أرى داعي أبداً لتنسيق كافة الصفوف والأعمدة بهذا الشكل ، هذا يجعل الملف ثقيل وبطيء جداً المهم اتفضل الكود جرب وشوف Sub PullUniques() Dim A, I As Long, J As Long, N As Long, LR As Long With Sheets("Sheet1") LR = .Columns("B:M").Find("*", , , , xlByRows, xlPrevious).Row A = .Range("B3:M" & LR).Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For J = 1 To UBound(A, 2) For I = 1 To UBound(A, 1) If Len(A(I, J)) Then If Not .Exists(A(I, J)) Then .Item(A(I, J)) = Empty: N = N + 1 If N <> I Then A(N, J) = A(I, J): A(I, J) = Empty Else A(I, J) = Empty End If End If Next I N = Empty Next J End With .Range("O3").Resize(UBound(A, 1), UBound(A, 2)).Value = A End With End Sub تقبل تحياتي Customers New Only YasserKhalil.rar

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

إليك أخي الفاضل الملف التالي عله يكون المطلوب تم عمل ورقة تقرير ..اختار الاسم ثم انقر زر الأمر لتظهر البيانات المرتبطة بهذا الاسم Sub Report() Dim WS As Worksheet, SH As Worksheet Dim I As Long, lRow As Long, LR As Long Set WS = Sheets("نور البيان "): Set SH = Sheets("Report") lRow = 6 Application.ScreenUpdating = False With SH.Range("D6:K1000") .ClearContents: .Interior.Color = xlNone End With Call UniqueNames For I = 7 To 506 If WS.Cells(I, "C") = SH.Cells(3, "C") Then WS.Cells(I, "C").Offset(, 1).Resize(1, 8).Copy SH.Cells(lRow, "D").PasteSpecial xlPasteValues lRow = lRow + 1 End If Next I SH.Range("D7:H1000").ClearContents LR = SH.Cells(Rows.Count, "I").End(xlUp).Row + 1 With SH.Range("I" & LR) .Formula = "=SUM(I6:I" & LR - 1 & ")": .Value = .Value: .Interior.Color = 10092441 If .Value = SH.Range("H6") Then MsgBox "تم سداد المبلغ بالكامل", 64 Else MsgBox "المبلغ لم يتم سداده بالكامل ما زال هناك أقساط متبقية", vbExclamation End If End With SH.Range("C3").Select Application.CutCopyMode = False Application.ScreenUpdating = True End Sub Sub UniqueNames() Dim Rng As Range Dim Dn As Range Dim Dic As Object With Sheets("نور البيان ") Set Rng = .Range("C7:C506") End With Set Dic = CreateObject("Scripting.Dictionary") Dic.CompareMode = vbTextCompare For Each Dn In Rng If Not IsEmpty(Dn) Then Dic(Dn.Value) = Empty Next Dn Sheets("Report").Columns(15).ClearContents Sheets("Report").Range("O1").Resize(Dic.Count, 1).Value = Application.Transpose(Dic.keys) End Sub Report Summary.rar

اخى الكريم اليك احد الحلول ..... ولعلك تجد عند اساتذتى افضل منها If Date <= DateSerial(2015, 8, 20) Then 'code هنا يوضع Else End End If فكرة هذا الكود هو التنفيذ حال ان التاريخ اقل من او يساوى تاريخ معين تقبل تحياتى

ما هو نظام التشغيل الذي تعمل عليه لوكان ويندوز 7 يمكنك من خلال لوحة التحكم Control Panel النقر على Region and language ثم التبويب Administrative ثم انقر الزر المكتوب عليه Change System Locale واختار من القائمة أي دولة عربية ثم موافق ثم أعد تشغيل الجهاز

أخي الفاضل أبو لجين إليك الدالة التالية وإن شاء الله تفي بالغرض بالنسبة لأي طلب جديد لا يخص هذا الطلب يرجى طرح موضوع مستقل Function CalString(sInp As String) As Long Static bInit As Boolean Dim asMap() As String Dim asLtr() As String Dim I As Long Static aiVal(0 To 255) As Long If Not bInit Then asMap = Split("1 1 1 1 1 1 2 3 4 5 6 7 8 9 10 20 30 40 50 60 70 80 90 100 200 300 400 500 600 700 800 900 1000") asLtr = Split("ء أ إ آ ا ئ ب ج د ه و ز ح ط ي ك ل م ن س ع ف ص ق ر ش ت ـة ث خ ذ ض ظ غ") For I = 0 To UBound(asMap) aiVal(Asc(asLtr(I))) = asMap(I) Next I bInit = True End If For I = 1 To Len(sInp) CalString = CalString + aiVal(Asc(Mid(sInp, I, 1))) Next I End Function وإليك أيضاً ملف مرفق فيه تطبيق لاستخدام الدالة تقبل تحياتي ABJAD Calculator UDF Function YasserKhalil.rar

الأخ الكريم أحمد إثراءً للموضوع إليك الكود التالي ..قم بالضغط على زر الأمر "قل : الحمد لله" في ورقة العمل الثانية لتظهر لك النتائج تقريباً كما أرفقتها في المشاركة الأولى .. Option Explicit Sub ExtractExistingNonExisting() Dim Coll As New Collection, Arr1, Arr2, ArrOut(), Str1 As String Dim pDup As Long, pUniq As Long, I As Long, P As Long With Sheets("Sheet1") Arr1 = .Range("A1").CurrentRegion.Value Arr2 = .Range("D1").CurrentRegion.Value End With ReDim ArrOut(1 To (UBound(Arr1, 1) + UBound(Arr2, 1)), 1 To 8) On Error Resume Next For I = 1 To UBound(Arr2, 1) Coll.Add Key:=CStr(Arr2(I, 1)), Item:=I Next I On Error GoTo 0 For I = 1 To UBound(Arr1, 1) On Error Resume Next Str1 = CStr(Arr1(I, 1)) P = Coll(Str1) If Err Then pUniq = pUniq + 1 ArrOut(pUniq, 7) = Arr1(I, 1) ArrOut(pUniq, 8) = Arr1(I, 2) Else pDup = pDup + 1 ArrOut(pDup, 1) = Arr1(I, 1) ArrOut(pDup, 2) = Arr1(I, 2) ArrOut(pDup, 4) = Arr2(P, 1) ArrOut(pDup, 5) = Arr2(P, 2) Coll.Remove (Str1) End If On Error GoTo 0 Next I For I = 1 To Coll.Count P = Coll(I) pUniq = pUniq + 1 ArrOut(pUniq, 7) = Arr2(P, 1) ArrOut(pUniq, 8) = Arr2(P, 2) Next I Sheets("Sheet2").Range("A1").Resize(UBound(ArrOut, 1), UBound(ArrOut, 2)).Value = ArrOut End Sub Extract Existing Non-Existing From Two Lists YasserKhalil.rar

جميل جدا استاذ غسان لي ملاحظة وهو طلب فضلا وليس امرا : نريد البيانات المدخلة بيانات حقيقية ! الاهداف - الانشطة وغيرها ! لو بمثال سابق لديك هذا ولك كل الشكر

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

السلام عليكم أخي الصقر : يرجى الانتباه إلى أنك لم ترفق الملف ضمن هذه المشاركة...لعلك نسيت..تقبل تحياتي العطرة.

http://www.kutub.info/library/category/19

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