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

السلام عليكم ورحمة الله وبركاته كل عام وانتم الى الله اقرب كل اساتذتى الكرام الأفاضل واخوانى واحبابي فى الله هدية شهر رمضان المعظم اليكم حاولت جاهدا الانتهاء من هذة الجزئية التطبيق قيد التطوير فى الإصدار السابق كان يمكن فقط الاستماع الى القراء عبر شبكة الانترنت حسب الرابط المضاف لكل قارئ داخل الجدول الان تم التطوير بفضل الله تعالى ليشمل امكانية اضافة رابط مكان ملفات القران الكريم من الحاسوب وبذلك يمكن الاستماع اما عبر الانترنت او عبر الحاسوب بدن اتصال بالانترنت للقراء الذين تحب ان تسمع اصواتهم رجاء التاكد فقط من ان تكون الملفات مسلسلة بنفس طريقة الاسم والرقم للسورة كما بالمرفق وارفقت لكم البرنامج الذى استخدمه لتسمية ملفات القران الكريم دفعة واحدة باسم السورة والترقيم يمكنكم التعديل على جدول القراء باضافة مسار القارئ واسمه والتاكد من التأشير ب علامة صح على الحقل من الجهاز اسم الجدول هو. tblDataServerQuran انتظر ردودكم بعد التجربة المرفق حصري غير منقول بفضل الله تعالى التصميم والتطوير حصرا بفضل الله من أفكار العبد لله واقدمه لكن مفتوح المصدر واسمح لوجه الله تعالي بنقله او تطويره حسب ارادتكم وكيفما شئتم واخيرا وليس اخرا احبكم فى الله الاصدار_الثانى_من_قاعدة_بيانات_القرآن_الكريم_الاستماع_لتلاوة_الذكر_الحكيم.zip

find_count_text.mdb

السلام عليكم و رمضان كريم 1- ليس للمرة الأولى اكرر انه لا لزوم ادراح بيانات من ألوف الصفوف (6000 صف) اذ يكفي ادراج نموذج صغير فقط لأن الماكرو الذي يعمل على صف واحد يمكنه العمل على الألوف منها ( فقط من ـأجل معاينه عمل الماكرو وتخفيف حجم الملف) 2-تم اخفاء بعض الاعمدة (وليس حذفها ) لمراقبة سير الكود والتمكن من رؤية الييانات/ يمكن اعادة اظهارها بسهولة 3- تم ارفاق نموذج عما تريد مع بضعة صفوف 4-الكود Option Explicit Sub copy_data() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim S As Worksheet, T As Worksheet Dim Ros#, Rot#, x%, Num%, m% Set T = Sheets("Target_sh") Set S = Sheets("Source_sh") Ros = S.Cells(Rows.Count, 1).End(3).Row If Ros < 3 Then GoTo Leave_me_alone_Please Rot = T.Cells(Rows.Count, 1).End(3).Row If Rot < 2 Then GoTo Leave_me_alone_Please T.Range("A3:N" & Rot + 1).Clear m = 3 For x = 3 To Ros Num = S.Cells(x, "L") S.Cells(x, 1).Resize(, 13).Copy With T.Cells(m, 1).Resize(Num, 13) .PasteSpecial 12 .PasteSpecial 8 End With m = T.Cells(Rows.Count, 1).End(3).Row + 2 Next T.UsedRange.SpecialCells(xlCellTypeConstants).Borders.LineStyle = 1 Leave_me_alone_Please: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .CutCopyMode = False End With End Sub الملف مرفق Date_distribution.xlsm

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

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

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

وعليكم السلاك ورحمة الله وبركانه 🙂 ماشاءالله عليك باشمهندس ، وفي الوقت الصحيح في هذا الشهر الفضيل 🙂 جعفر

امساكية شهر رمضان 1441هـ 2020 م القاهرة - مصر ( فى رحاب الصحابة) ملف اكسل vba تفضل تم رفعه مباشرة على ميديا فاير ... لأن هذا افضل وأسهل بكثير إمساكية رمضان 1441 هـ

الاصدقاء الاكارم تحية طيبة في التطبيق التالي سنقوم بحماية ملف الاكسل عت طريق رقم الفلاش الميموري الحقيقي ( الرقم الذي لا يتغير ) خطوات التنفيذ : 1 - نقوم باستخراج رقم الفلاش ميموري الحقيقي 2 - نضيف الوحدة النمطية الى المصنف المطلوب حمايته 3- نفعل الحماية نبدأ على بركة الله 1 - في الملف المرفق يوجد زر امر يقوم باستخراج رقم الفلاش ميموري و تسجيله في الخلية a1 2 - نضيف الوحدة النمطية module2 الى الملف الذي نرغب بحمايته مع مراعات استبدال رقم الفلاش ميموري برقم الفلاش الموجودة لدينا حيث نقوم بوضع الرقم هنا If objItem.PNPDeviceID = "USBSTOR\DISK&VEN_TAKEMS&PROD_USB_RETRO&REV_5.00\011114007BC74103&0" Then 3 - نستدعي كود الحماية عند فتح المصنف Private Sub Workbook_Open() Call Pro End Sub حماية برقم الفلاشة الحقيقي.xlsm

الشكر لله ثم لاخواننا واساتذتنا جزاهم الله خيرا اللهم آمين بالتوفيق اخى

Private Sub CommandButton1_Click() Me.ListBox6.ColumnCount = 3 Me.ListBox6.ColumnWidths = "10;50;200" lr = Cells(Rows.Count, 1).End(xlUp).Row For i = 59 To lr - 1 b = i Me.ListBox6.AddItem Me.ListBox6.List(b - 59, 1) = Sheets("level1").Cells(b, 1) Me.ListBox6.List(b - 59, 2) = Sheets("level1").Cells(b, 2) Next i End Sub تفضل. يمكن أن تستغني عن b . و تضع i فقط. تركتها لاووضح لك التعديل على كودك. القائمة تبدأ من الصف 59. المصنف1.xlsm

تفضل تعديل (1).xlsm

السلام عليكم اخى الفاضل @AboBahaa تم اضافه استعلامين qryTABLE2 و qryTblNew واضافه حقلين باسم t فى كل منهما لتجميع حقل الرقم والمركز والسنه والنوع وذلك للمقارنه لعدم اضافتهما مره اخرى للبيانات فى حاله تم الضغط اكثر من مره ع زر الاضافه وتم تعديل استعلام الالحاق بناء عليهما تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق برنامج العقود_1.rar

اخي الكريم عليك دائما التفكير في كل الاحتمالات الممكنة حتى لو كانت نسبتها شبه معدومة في فكرتك هناك ثغرة وهي سيئة جدا لنفرض انك في شهر ابريل و فتحت ملف يعود لشهر مارس عند تطبيق الكود سيتم التنفيذ على مجلد شهر ابريل و ليس مارس هل لك ان تتخيل حجم الكارثة ؟؟ في حال السهو و الضغط على موافق لاستبدال النسخة الاحتياطية ستفد ملفات شهر ابريل كافة و سيتم استبدالها بملف شهر مارس عندها ستبدا رحلة البحث عن برامج استعاد الملفات المحذوفة وكيفية استعادة ملفات الاكسل المحفوظة سابقا و لن تحصل على النتيجة المطلوبة من وجهة نظري و حسب اغلب برامج المحاسبة لا يقوم البرنامج بحذف النسخة الاحتياطية ابدا (الحذف يتم يدويا)

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

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

بسم الله ماشاء الله على هذا العمل الممتاز جزاك الله كل خير

حفظك الله استاذنا

تفضل يمكنك هذا بهذه المعادلة =IFERROR(INDEX($A$2:$A$7,MATCH(E2,$B$2:$B$7,0)),"") الوقت الحالى.xlsm

بارك الله فيك وجعل الله هذا العمل فى ميزان حسناتك ان شاء الله

وعليكم السلام اخى @ازهر عبد العزيز ممكن تعمل خدعه بسيطه تعمل زر وتجعله شفاف فوق الصوره وتجعل الزر عند التحميل غير مفعل ثم بالضغط ع زر اخر يتم ارسال الزر للخلف وتنشيط الصوره وتصير مفعله وجزاها ام عهود لانى صرت ابحث عن الكود ده فى جوجل بالترجمه المقرفه لحد ما ربنا هدانى للبحث بطريقه اخرى ووصلت لطريقه لام عهود جزاها الله خيرا واليك مثال عندما تفتح الفورم عندك صوره للبيت حاول تضغط عليها لن تعمل اضغط عالزر امر 6 ثم اضغط عالبيت مره اخرى جرب ووافنى بالنتيجه New - Copy (2).accdb

مشاركه معكم اخوانى ارفق مثال كان موجود عندى لعله ينفعكم ان شاء الله وجزاه الله خيرا صاحبه -بحث في نص طويل وتضليل النتيجة وعدد الكلمات المكررهSearchByWord.rar

جرب هذه فهي افضل باك اب لغاية الان حسب اعتقادي Backup.mdb

كيف يعني غير ممكن اذا تقصد اخفاء واظهار الصورة استعمل امر visible بدل من enable التمكين لمربع نص للكتابة بداخلة وليس للصورة حسب معلوماتي المتواضعه

تمام تمام بارك الله فيك طيب نجرب معا : اعمل مربع نص للبحث وليكن اسمه part ومربع نص آحر به النص الكامل وليكن اسمه text ثم اكتب أمر MsgBox UBound(Split(Me.Text, Me.part)) و الآن اكتب كلمة في مربع البحث واكتب في مربع النص مجموعة كلمات بها الكلمة التي تريد البحث عنها ونفذ الأمر فستظهر رسالة عددية تساوي عدد مرات وجود الكلمة أو تتابع الأحرف الذي كتبته في مربع البحث جرب هذا أولاً ثم نجربه على جدول إن شاء الله

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

اعشق التحدي

أعتقد استاذ محمد انه يقصد هذا عند الضغط على قائمة File مثلاً فى الإكسيل ستظهر هذه النافذة كما بالصورة وتظهر بها قائمة New أو يمكنك الضغط على مفتاحى Ctrl+N لفتح ملف جديد على الإكسيل ان لم تتمكن من حل المشكلة هكذا فعليك بتتبع الخطوات وتنفيذها كما بالرابط التالى : How to fix Excel 2016 Opening Blank Workbook Issue أو هذا الرابط ايضا Fix Excel 2016 opening a blank document

الله يكون في العون والحمد لله على كل حال لا تتعب حالك أخي ليس بالمهم . وشكراً لك

الحمد لله رب العالمين شكراً 🙏🌹 تلقائيا لن استطيع عملها 🤔 لانه ربما لو حددنا مجلد توضع فيه مجلدات باسماء القراء لا اعلم هل يمكن لكود ان يقوم بقراءة اسماء المجلدات وإحضارهم لكتابة المسار برمجيا كما اننى فى الوقت الحالى اعانى من انقطاع الانترنت ولا استطيع البحث على شبكة بأريحية من الجوال ان امكنكم تقديم يد العون فجزاكم الله خيرا على كل ساحاول ان شاء الله فعلت ذلك مع مشغل الوسائط لو تتذكر ولكن كانت ملفات اما هنا نريد احضار اسماء مجلدات من مساار محدد

بعد تجربة الاستماع من خلال الانترنت ممتاز جداً . أما تجربة الاستماع من خلال ملفات منزلة على جهاز الحاسب لم يعمل معي لأول مرة . حتى قمت بالدخول على جدول المسارات tblDataServerQuran كما أشرت في موضوع أعلاه 👆وتغيير موقع الملف يدوياً والحمد لله ويعمل الآن بشكل ممتاز . كما اتمنى أن يكون تغيير الرابط تلقائيا أو من خلال تحديد الملف برمجياً . وشكراً لكم من الأعماق محبك في الله آبوآمنة

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

اعتذر لتاخرى فى الرد على حضراتكم خدمة الإنترنت سيئة جداً ولازلت انتظر الرد بعد التجربة اريد الوقوف على نقاط الضعف والقوة فى الافكار والتصميم والتكويد وتجربة ال End User اعرف انى اشق على اساتذتى واحبابي ولكن دون توجيهاتكم وارشادتكم لطلاب العلم ما تقدم منهم احد شكرا 🙏🌹 والدى الحبيب واستاذى الجليل ومعلمى القدير استاذ @jjafferr شكرا 🙏🌹 اخى الحبيب واستاذى الجليل ومعلمى القدير استاذ @أحمد الفلاحجى شكرا 🙏🌹 اخى الحبيب واستاذى الجليل ومعلمى القدير استاذ @ابوآمنة

الخطأ في الفرز لأنه كان يفرز حقل نص ، فاستبدلت الحرف A بالرقم 9999999999 (يعني رقم كبير) ، ثم استخدمت الدالة val لتحويل القيمة الى رقم : . ونفس الشيء في التقرير ، فطلعت النتيجة : . جعفر 1212.1.TEST_QUERY(1).accdb.zip

السلام عليكم ورحمة الله تحية طيبة وبعد ,,, تم تعديل الملف ليتوافق مع الوقت المسموح بيه بالانصراف او الحضور الملف المرفق : راتب_الموظف_من_عن_طريق_البصمة.xlsm

السلام عليكم ورحمة الله وبركاته هذا طلب للاخ ذيب اليمن وجعلناه هنا لتعم الفائدة ملاحظات : اذا لم تكتب اي تاريخ هو يعين التواريخ تلقائيا من اصغر تاريخ في العمود C الى اكبر تاريخ ====================== مع امكانية التحكم بعرض اعمدة اللست من خلال عرض الليبلات الي فيها عنوان العمود اثناء التصميم المرفق 2003 total.rar

السلام عليكم جمعة مباركة فورم بحث جميل وبامكانيات مرنة (وسنتعلم منه الكثير) هو طلب لاحدهم ولكني جعلته هنا لانه مهم للكثير الموضوع في الرابط ادناه http://www.officena....opic=42261&st=0 المرفق 2003-2007 ملف بحث بفورم ممتاز.rar

وعليكم السلام انت لخبطت الكود وكنسلت خلية الارتباط عموما هذا طلبك وبلاش الالوان والحاجات اللي تثقل الملف علشان يعمل معاك تمام Option Explicit '============================================= ' اسم ورقة وضع نتائج البحث Const sNamePast As String = "نتائج البحث" ' اسم ورقة البحث Const sNameFind As String = "البحث في المكتبة" '============================================= Sub Kh_Find() Static MySve As String Dim MyTextFind As Variant Dim FirstAddress As String Dim sFind As Worksheet Dim RngPast As Range Dim RngFind As Range Dim cel As Range Dim i As Long Dim ii As Long On Error GoTo 1 '==================================== ' الصف الاول من خلايا وضع النتائج Set RngPast = Worksheets(sNamePast).Range("B3:G3") '==================================== With RngPast .Worksheet.Activate .Range("A1").Activate .Offset(1, 0).Resize(.Worksheet.UsedRange.Rows.Count).EntireRow.Delete .ClearContents End With MyTextFind = Application.InputBox("اكتب ما تريد البحث عنه ؟", "بحث", MySve, 100, 100, , , 2) If MyTextFind = "" Or MyTextFind = False Then GoTo 1 '==================================== Set sFind = Worksheets(sNameFind) Set RngFind = sFind.Columns(3).Cells '==================================== '==================================== Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '==================================== Set cel = RngFind.Find(MyTextFind, LookIn:=xlValues) If Not cel Is Nothing Then FirstAddress = cel.Address Do ii = cel.Row If ii = 1 Then GoTo NX i = i + 1 With RngPast .Cells(i, 1) = sFind.Cells(ii, "A").Value .Cells(i, 2) = sFind.Cells(ii, "B").Value .Cells(i, 3) = sFind.Cells(ii, "C").Value .Cells(i, 4) = sFind.Cells(ii, "E").Value .Cells(i, 5) = sFind.Cells(ii, "F").Value .Cells(i, 6) = sFind.Cells(ii, "H").Value kh_AddHlink .Cells(i, 1), ii End With NX: Set cel = RngFind.FindNext(cel) Loop While Not cel Is Nothing And cel.Address <> FirstAddress End If '==================================== If i Then MySve = MyTextFind With RngPast .AutoFill .Resize(i), xlFillFormats End With End If '==================================== 1: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic If Err Then MsgBox "Err.Number : " & Err.Number: Err.Clear End If Set sFind = Nothing Set RngPast = Nothing Set RngFind = Nothing Set cel = Nothing End Sub ' اضافة ارتباط تشعيبي Sub kh_AddHlink(HRng As Range, iR As Long) Dim sAdr As String sAdr = "'" & sNameFind & "'!" & Range("A" & iR).Address HRng.Worksheet.Hyperlinks.Add HRng, "", sAdr, sAdr End Sub كود بحث في عدة اوراق.rar

بداية الكود تجد اعدادات الكود يمكنك التغيير فيها Option Explicit '====================================================== '====================================================== ' اسم نطاق رؤوس الاعمدة ' او عنوان رؤوس الاعمدة ملحوقة باسم الورقة Private Const MyTopColmnRng As String = "بيانات!$A$5:$K$5" ' MyTopColmnRng رقم عمود رقم الحساب من النطاق Private Const MyColmnFind As Integer = 2 ' MyTopColmnRng رقم عمود التاريخ من النطاق Private Const dColmn As Integer = 9 ' MyTopColmnRng عدد الاعمدة المطلوبه من النطاق Private Const ContColmn As Integer = 7 ' ContColmn ارقام الاعمدة المطلوبه من النطاق حسب العدد المطلوب Private Const sColmn As String = "4,6,8,5,9,7,10" '====================================================== '====================================================== Sub kh_ClearContents() Dim P As Integer Dim Adr As String For P = 1 To 3 Adr = Choose(P, "B5", "B47", "B89") Range(Adr).Resize(32, ContColmn).ClearContents Next End Sub Sub kh_Start() Dim MyRng As Range Dim R As Integer, c As Integer Dim ContRow As Integer, i As Integer, ii As Integer, iii As Integer Dim tFindNum As String Dim dt1 As Date, dt2 As Date '------------------------- On Error GoTo 1 '------------------------- Set MyRng = Range(MyTopColmnRng) '------------------------- kh_ClearContents '------------------------- With MyRng ContRow = .Worksheet.Cells(Rows.Count, .Column).End(xlUp).Row - .Row End With If ContRow = 0 Then Exit Sub '------------------------- ' خلية رقم الحساب المطلوب tFindNum = LCase(Range("H1")) '------------------------- ' خلايا التاريخ dt1 = DateValue(Range("K1")) dt2 = DateValue(Range("K2")) '------------------------- Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '------------------------- With MyRng.Offset(1, 0) For R = 1 To ContRow Select Case .Cells(R, dColmn).Value2: Case dt1 To dt2 'ib = LCase(.Cells(R, MyColmnFind)) Like tFindNum If LCase(.Cells(R, MyColmnFind)) Like tFindNum Then ii = ii + 1 For c = 1 To ContColmn i = Split("," & sColmn, ",")(c) Range("B5").Cells(ii, c).Value = .Cells(R, i).Value Next iii = iii + 1 ' اذا وصلت البيانات الى مضاعف 32 تزداد بمقدر 10 If iii Mod 32 = 0 Then ii = ii + 10 End If End Select Next End With 1: '------------------------- Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic '------------------------- If Err Then MsgBox "Err.Number : " & Err.Number Else If iii Then MsgBox "تم الترحيل بنجاح ", vbMsgBoxRight, "الحمدلله" Else MsgBox "لا توجد نتائج للبحث", vbMsgBoxRight, "عفوا" End If End If Set MyRng = Nothing End Sub المرفق 2003/2007 حسابات1.rar

اكرمك الله اكرام الصالحين ورزقك الفردوس انت واهلك وذويك ومن تحب تقبل تحياتي وشكري

السلام عليكم في المرفق التالي 2003 استخدمت لست واحد فقط واضفت امكانية تحديد الخلية بدبل شيك على اللست اضافة اخي الحبيب عبدالله المجرب ودمتم في حفظ الله total2.rar

شكرا ابا جود .. جعله الله في ميزان حسناتك ملاحظتي : لم يفتح عندي لان النظام عندي 32 بت ، الكثير من الأسطر بحاجة الى تعديل ليس هذا طلب للتعديل .. ولكنها ملاحظة قد تقولون: قريبا ستختفي النواة 32 فلن نجد من يعمل عليها