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

السلام عليكم ورحمة الله وبركاته طرح في موضوع سابق موضوع رسائل الواتس اضع بين يديكم برنامج يقوم بارسال رسائل الواتس بدون حفظ الرقم في جهات الاتصال ويمكن استخدامه وتطويره لارسال رسائل للعملاء مثلا جربوه واعطونا انطباعكم حوله لتطويره والاستفادة منه ملاحظة هامة يجب تنصيب رنامج الواتس في جهازك ليعمل البرنامج هناك مدة زمنية وضعتها في الكود للتنفيذ مقدارها 40 يمكنك تغييرها ليتناسب مع سرعة جهازك ...... الطريقة سهله أوضحها باختصار مع اقتران كل شرح بالصورة ..... أولا : الذهاب للرابط https://www.whatsapp.com/download وتحميل برنامج الواتس حسب نسخة الويندوز لديك ( 64 - 32 )bit ثانيا: تشغيل برنامج الواتس والتسجيل عن طريق حسابك في الواتس وذلك بمسح البركود الظاهر في البرنامج من خلال البرنامج ( حسب الصورة ) ثالثا : عند اول تشغيل تظهر لك من خلال المتصفح رسالة بالسماح بفتح الارتباط بهذا النوع ( ضع علامة صح مثل الصورة ) رابعا : عند عمل البرنامج للمرة الثانية لا يحتاج تكرار هذه العمليات ( فقط انتظر اتمام المهمة ) هناك في الكود زمن افتراضي وضعته هو 40 ثانية أن رأيت جهازك والنت سريع حاول تقليل الزمن لكسب سرعة في الارسال أو العكس بالعكس تسجيل الارقام بالصيغة الدولية .... منتظر انطباعاتكم حول البرنامج ؟؟؟؟ WhatsApp_kan.accdb هنا تجدون الموضوع السابق ......

السلام عليكم عندما شاهدت برنامج الأستاذ محمد سلامة , حقاَ كان برنامج صغير لكن كان فيه الكثير من الجهد المبذول للحفاظ على بقاء الألوان كما أختيرت حتى بعد الخروج من البرنامج والعودة إليه من جديد أحي الأستاذ محمد سلامة على مجهوده الرائع بعدها حاولت الكثير لتطبيق الدوال والأكواد على إختيار اللغة إما عربية أو إنجليزية لكني للأسف لم أتوصل لنتيجة مقنعة لذلك أرجو المساعدة من الأستاذ محمد سلامة بالإضافة إلىSave User Options.accdb الأخوة أصحاب الخبرة لإنجاح البرنامج

تم التعديل على الملف قليلا من حيث المظهر والتنسيق Option Explicit Sub MY_code() Rem Created by Salim Hasbaya On 19/10/2020 Application.ScreenUpdating = False Dim B As Worksheet, Tas As Worksheet Dim arr() Dim i%, t%, col%, p%, n%, Q%, LB% Dim St$, itm As Variant Dim Rg As Range Set B = Sheets("البيان") Set Tas = Sheets("التصنيفات") Set Rg = Tas.Range("B1").CurrentRegion If Rg.Rows.Count = 1 Then GoTo Ma_Lish_Da3wa Set Rg = Rg.Offset(1).Resize(Rg.Rows.Count - 1) LB = B.Cells(Rows.Count, 2).End(3).Row B.Range("D2").CurrentRegion.ClearContents If LB = 1 Then GoTo Ma_Lish_Da3wa For i = 1 To Rg.Cells.Count If Rg.Cells(i) <> "" Then ReDim Preserve arr(t) arr(t) = Rg.Cells(i) t = t + 1 End If Next t = 2 B.Range("D2").Resize(LB - 1) = _ B.Range("B2").Resize(LB - 1).Value '+++++++++++++Creating The Data +++++++++++++ For i = 2 To LB If B.Range("D" & i) <> vbNullString Then For Each itm In arr If InStr(B.Range("D" & i), itm) Then col = Rg.Find(itm, lookat:=1).Column St = Replace(B.Range("D" & i), itm, "*") col = Rg.Find(itm, lookat:=1).Column St = Replace(St, "*", Tas.Cells(1, col)) B.Range("D" & i) = St End If Next itm End If Next i '+++++++++++++ End Of Creating The Data +++++++++++++ Erase arr ReDim arr(1 To 3) For i = 1 To 3 arr(i) = Tas.Cells(1, i + 1) Next p = 1 '+++++++++++++Formating with Red Color +++++++++++++ For i = 2 To LB For Each itm In arr Do Q = InStr(p, B.Range("D" & i), itm) If Q = 0 Then Exit Do n = InStr(Q, B.Range("D" & i), " ") p = p + n + 1 B.Range("D" & i).Characters(Q, n - Q). _ Font.ColorIndex = 3 Loop p = 1 Next itm Next i '++++++++++++++End Of Formating with Red Color +++++++++++++ Ma_Lish_Da3wa: Set B = Nothing: Set Tas = Nothing Set Rg = Nothing: Erase arr Application.ScreenUpdating = True End Sub الملف من جديد مع الكودين القديم والجديد Mh_Fayz _New.xlsm

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

بلی ممكن ، تقدر تستخدم دالة DCount و DMax اذا عدد سجلات بيكون يساوي مع رقم الکبیر في الجدول هو يعني الترقيم ليس فيها نواقص واذا غير متساويين هناك بيعمل كود وسيتم ترقيم جديد

بالخدمة اخي العزيز ساحاول لكن منطقيا غير ممكن اولا: الكود لا يعمل اذا كانت هناك علاقة مع جدول او اكثر ثانيا : حتى لو كان من الممكن جعل الكود يعمل مع وجود علاقة فبالتاكيد سوف يحدث خلل في البيانات خصوصا وانت قد جعلته مفتاح رئيسي لانه بصورة مبسطة لو كانت عند ارقام 1و2و4 فان بقية الجداول المرتبطة به يجب ان تحتوي فقط على هذه الارقام ولاعادة تسلسل الترقيم سوف نفك العلاقات وهو امر عادي ثم نعيد الترقيم وسيكون 1و2و3 هنا تحدث المشكلة حيث انه لا يمكن اعادة العلاقات مرة اخرى لان بقية الجداول تحتوي الرقم 4 ملاحظة : هناك طريقة واجدها مناسبة ولا تسبب خلل وهي ان نجعل حقل اخر من نوع رقم نعمل له التسلسل وهذا الحقل هو الذي يظهر للمستخدم فلا يلاحظ عدم الترتيب بحقل الرقم التلقائي وهذه الطريقة تحافظ العلاقات للاننا في الحقيقة نتعامل مع حقل اخر لا دخل له باي عملية سوى انه يظهر بشكل متسلسل وعذرا للاطالة

بالخدمة استاذ Ahmed_J في خصائص حقل الترقيم التلقائي اجعل الفهرسة Yes(No Duplicates) وذلك قبل ان تجعلهمفتاح اساس اي هذه الخاصية تكون ثابتة سواء كان مفتاح اساسي او لا test2.rar

وهذا تعديل ما ذكر اعلاه تقاعد-1.rar

بالخدمة استاذ alsihran الحل تم بناءا على معطياتك نعم ممكن وهذا التعديل حسب فهمي لطلبك Adddte-root3.rar

السلام عليكم ورحمة الله وبركاته تم بفضل الله تعالى إنجاز الخاصية الجديدة في إضافة البيان البحثية: رابط الفيديو الذي يشرح الخاصية بشكل مفصل: رابط مباشرة لتحميل آخر إصدار من إضافة البيان البحثية: https://www.shhada.net/contents/downloadsm/4MAEgubYzqynkm6y.zip ما رأيكم الآن أيها الأحباب؟

أحمد عمر شوقى أين انت من كل هذه الإجابات الممتازة؟!!! أين الضغط على الإعــــجـــــاب , وكما اتفقنا ان هذا أقل ما يقدم لمن له الفضل عليك بعد ربنا فى حل مشكلتك وتفريج كربتك ؟!!!💙ولا تتعالى عن فعل هذا حتى لا تنصرف الأساتذة عن مساعدتك لأنك بهذه الطريقة لا تعطى كل صاحب حق , حقه لأنه غير ملزم وغير مجبر على الرد على مشاكلك وتساؤتك .. فعلى الأقل هذا أقل تقدير منك تجاهه بتضحيته بالوقت والجهد لتقديم المساعدة لك

?? تصنيف الوصف.xlsm

جرب كده أعتقد لا يوجد مشكلة الأن SHAIMA1 H.xlsm

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

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته للتسهيل على من يقوم بعمل جداول أرقام عربي ويحاول إيجاد نوع خط يظهر الأرقام واضحة فهذا الكود يمكن عن طريقه سرد جميع الخطوط الموجودة وإظهار الأرقام باستخدام هذه الخطوط برجاء التجريب وإرسال تعليق لتحسن هذا الكود - تم تعــديــل المـــلف جميع اسماء الخطوط1.xls

شكراً لك أخ roshet11 على الدعاء الطيب ولك مثله أضعافاً مضاعفة أيضاً يمكن أن يكون هكذا Sub test() With Sheet1 lr = .Cells(Rows.Count, 2).End(xlUp).Row For i = 2 To lr x = Split(.Cells(i, 2), " ") Set fin = Sheet2.Range("b2:d20").Find(x(4)) .Cells(i, 3) = Sheet2.Cells(1, fin.Column) x(4) = Sheet2.Cells(1, fin.Column) x = Join(x, " ") .Cells(i, 6) = x Next End With End Sub

السلام عليكم تفضل هذه المحاولة ارجو ان تكون موفقة ملاحظة : كود اخر لكن يقوم بنفس العمل ReAutoNumber-3.rar

تفضل التعديل Adddte-root2.rar

بالخدمة استاذ AboBahaa

بعد ادن اخي محي الدين و زيادة في اثراء الموضوع هذا الكود Option Explicit Sub test_1() Dim arr(), i%, t%, itm, col% Dim B As Worksheet Dim Tas As Worksheet Set B = Sheets("البيان") Set Tas = Sheets("التصنيفات") B.Range("D2").CurrentRegion.ClearContents Dim Rg As Range Set Rg = Tas.Range("B2:D20") For i = 1 To Rg.Cells.Count If Rg.Cells(i) <> "" Then ReDim Preserve arr(t) arr(t) = Rg.Cells(i) t = t + 1 End If Next t = 2 For i = 2 To 9 For Each itm In arr If InStr(B.Cells(i, 2), itm) Then col = Rg.Find(itm, lookat:=1).Column B.Cells(t, 4) = Replace(B.Cells(i, 2), _ itm, Tas.Cells(1, col)) t = t + 1: Exit For End If Next itm Next i End Sub الملف مرفق Mh_Fayz.xlsm

عفواً مع العلم (لخخخلث google غشاخخ yahoo) هماك خطأ في جدول البيان احتياطاً Sub test() With Sheet1 lr = .Cells(Rows.Count, 2).End(xlUp).Row For i = 2 To lr x = Split(.Cells(i, 2), " ") Set fin = Sheet2.Range("b2:d20").Find(x(4)) .Cells(i, 3) = Sheet2.Cells(1, fin.Column) Next End With End Sub تصنيف الوصف.xlsm

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

تفضل هذا الكود شامل الشرح اخي الكريم On Error GoTo errorhandle Dim MyFilePath, MyRange, MyTablName As String 'MyFilePath = "مسار ملف الاكسل" MyRange = "نطاق الخلايا المراد استيرادها من ملف الاكسل" MyTablName = "اسم الجدول الذي سيتم تخزين البياناته به" '-------------------------------- '''''''' فتح مستعرض الملفات لإختيار الملف '''''''' Dim fpath As Variant With Application.FileDialog(3) .Title = "Choose File" .Filters.Clear .Filters.Add "Excel Files", "*.xls ; *.xlsx" .AllowMultiSelect = False .InitialFileName = "" If .Show = -1 Then MyFilePath = .SelectedItems(1) End If End With '-------------------------------- '''''''' استيراد ملف الاكسل حسب الشروط اعلاه '''''''' DoCmd.TransferSpreadsheet acImport, 10, MyTablName, FilePath, False, MyRange MsgBox "تم استيراد الملف بنجاح", vbMsgBoxRight + vbInformation, "تأكيد" errorhandleexit: Exit Sub errorhandle: MsgBox Err.Description Resume errorhandleexit

عليكم السلام استاذ AboBahaa تفضل التعديل ارجو ان يكون طلبك تحديث حساب العمر2.rar

هل جربت هذا Docmd.Open Docmd.OpenReport "NameForReport", acViewReport

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته أولا يجب أن تختار اتجاه النص من اليمين إلى اليسار ممكن تختار خط عربي يظهر في النص بصورة أفضل ومرفق ملف يمكن عن طريقه سرد جميع الخطوط وتجريب الأرقام العربي بها جميع اسماء الخطوط1.xls

المعذرة استاذ علي لم الحظ ردك لا بعد ان رفعت الملف جرب هذا الملف Facture.xlsx

وعليكم السلام لا يمكنك عمل هذا بمعادلة فلكوب العادية الا بعد عمل عمود مساعد او يمكنك استخدامها بطريقة مباشرة بعد جلب أول عمود بالفاتورة بهذه المعادلة المصفوفة (Ctrl+Shift+Enter) =IFERROR(INDEX(التفاصيل!$C$4:$C$800,SMALL(IF($F$6=التفاصيل!$A$4:$A$800,ROW($A$4:$A$800)-3),ROW(A1))),"") برنامج فواتير.xlsx

الأحبة الكرام أحتاج الى مبرمج لعمل برامج بسعر معقول أو مبرمج يرغب بالعمل في المدينة المنورة التواصل على الرقم 0553512200

تم وضع ملف جدبد بحتوي على 2 يوزر (يعملان على كل الصفحات) بالضغط على الزر المناسب الازرار موجودة في كل الصفخات 1- اليوزر القديم الذي ارسلته لك في مشاركة سابقة للبحث والتعديل و الجذف والاضافة 2- User جديد يمكن من خلاله البحث عن اي اسم من خلال كتابة الحروف الاولى من الاسم ( جرف أو 2 او 3 او فدر ما نريد ) فيTextBox الأصفر ثم الضغط على Enter تطهر لك في ال ListBox كل الاسماء التي تبدأ بهذه الجروف مع بياناتها تحتار الاسم الذي تربد من حلال الضغط عليه في ListBox فتظهر بياناته في TextBoxes كلها الملف مرفق toukilat 2 Users.xlsm

السلام عليكم ورحمة الله وبركاته هذا الكود يعمل علي جلب قيمة بعض الحقول واسماءها داخل الجدول عن طريق الدوران خلال كل الحقول بالجدول بشرط أن يكون حقل معين رقم وليس نص. هذا علي حسب فهمي. الكود الموجود بمشاركة حضرتك الاولي لم يظهر به بداية الكود والذي يجب أن يكون يحتوي علي: 1- تعريف لـــ Rst : وهو متغير سيتم تحديد نوعه الي Recordset - ليستعمل في تخزين بيانات الجدول وطريقة التعامل مع هذه البيانات. مثل: Dim rst As Recordset Set rst = Currentdb.OpenRecordset("TabelName",dbOpendynaset) 2- شرط الدوران داخل جقول الجدول ، مثل: For n=1 to rst.RecordCount -1 أو For Each field in rst.fields ثم من بداية الكود الذي ذكرته حضرتك شرط الحصول علي البيانات من داخل الجدول أن يكون الحقل المحدد يحوي رقم في هذا السطر والاسطر المشابهة له If IsNumeric(rst("F" & fld_Number + 16).Value) Then علي افتراض ان حقول الجدول لديك تسمي بهذا الشكل F1 , F2 , F100 .... fld_Number عبارة عن نص يحوي رقم فعليه يكون الشرط يعني لو الحقل المسمي f(1+16) قيمته رقم افعل أرجو أن يكون الشرح واضح وأني قد أفدتك بمعلومة ولو بسيطة تمنياتي بالتوفيق

فى ناس كتير بتكون فى أشغال فيها عد فلوس كتير مع العملاء أو المناديب - ومش بيكون عندهم ماكينة عد فلوس - او بيتعاملوا مع فلوس قديمة - الملف ده اكيد هايسهل عليهم عملية تجميع وتفقيط الفلوس بالعربي والانجليزي - بمجرد عد كل فئة وكتابة عددها باسوورد الملف 123 لأي صديق يريد تطوير الملف ليناسب أى عملات لأي دولة أخرى 0001 حاسبة النقود المصرية.xlsm

السلام عليكم أخواني الكرام اقدم للمنتدى برنامج محاسبة من تصميمي مع قاعدة بيانات للتجربة لكي يعمل البرنامج يرجى عمل ما يلي : 1- فك الضغط على القرص D حصريا 2- بعد تشغيل البرنامج يطلب تحديد قاعدة البيانات التي سيعمل عليها يجب اختيار قاعدة 2014 من ميزات هذا البرنامج أن معظم البرنامج يعتمد على الماكرو وأنا انتظر التقييم والردود الرابط https://drive.google.com/file/d/0B_ZrhTFFRjn3Mml3VWEyVjU0Qnc/view?usp=sharing مع تحياتي للجميع

السلام عليكم هذا قصدك أخي الكريم أليس كذلك

أخي الكريم // MKAREEM بارك الله فيك وجزاك خيرا اولا: لك دعوة كريمة بتغيير اسم الظهور الي اللغة العربية حسب سياسة منتدانا ولسهولة التعامل والمتابعة . ثانيا :- بالنسبة للملف عذرا لم انتبه ان محرر الكواد مغلق لاني بصفة عامة اتركه مفتوح المصدر للاستفادة منه وتطويعه لاي عمل اخر مرفق الملف مفتوح مع تحياتي الشيكات الأصدار الثاني.rar

السلام عليكم و رحمة الله وبركاته - - اخي في المرفق حل على قدر معرفتي - - اضغط على الزر يتم حفظ و رغلاق كامل الملفات الأخرى - - يمكنك نقل الكود الى مكان بدأ التشغيل في الملف لكي يتم تفعيله تلقائيا - - - مع التحية - - - mee.rar

ماذ عن هذا Sub test2() Dim lr, i Dim fin As Object Dim x As Variant With Sheet1 lr = .Cells(Rows.Count, 2).End(xlUp).Row For i = 2 To lr x = Split(.Cells(i, 2), " ") Set fin = Sheet2.Range("b2:d20").Find(x(4)) If fin <> "" Then .Cells(i, 3) = Sheet2.Cells(1, fin.Column) x(4) = Sheet2.Cells(1, fin.Column) x = Join(x, " ") .Cells(i, 5) = x Else .Cells(i, 5) = Join(x, " ") End If Next End With End Sub