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

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

السلام عليكم تفضل ما طلبته في الملف المرفق... بالمعادلات لا يمكن إخفاء أعمدة أو صفوف... بن علية حاجي présense.xlsm

جرب هذا الملف تم انشاء 12 ورقة تنقل اليها البيانات قبل ان تغير الشّهر Option Explicit Sub Give_Data() Dim st As String st = Sheets("Sheet3").Range("b7").Value Dim my_sh As Worksheet Set my_sh = Sheets(st) With my_sh .Cells.ClearContents .Range("d2").Resize(34, 32).Value = _ Sheets("Sheet3").Range("d2").Resize(34, 32).Value .Range("e4").Resize(, 31).NumberFormat = "ddd" .Range("e5").Resize(, 31).NumberFormat = "d" End With End Sub '============================================== 'janvier , février, mars, avril, mai, juin, juillet, aout, septembre, octobre, novmbre, decembre Sub sheets_name() Dim arr(1 To 12) Dim i% arr(1) = "janvier": arr(2) = "février": arr(3) = "mars" arr(4) = "avril": arr(5) = "mai": arr(6) = "juin" arr(7) = "juillet": arr(8) = "aout": arr(9) = "septembre" arr(10) = "octobre": arr(11) = "novmbre": arr(12) = "decembre" For i = 2 To 13 Sheets(i).Name = arr(i - 1) Next End Sub الملف مرفق présence_salim.xlsm

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

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

هذا الماكرو يقوم بما تريدين اختي الفاضلة Option Explicit Sub lena() If Sheets(1).[c4] = vbNullString Then Exit Sub Dim lr%, lr1% lr = Range("a" & Rows.Count).End(xlUp).Row If lr <= 5 Then MsgBox "No Data to Transfer", 64 Exit Sub End If lr1 = Sheets(Sheets(1).[c4].Value) _ .Cells(Rows.Count, 1).End(3).Row + 2 Sheets(1).Range("a6").Resize(lr - 5, 14) _ .Cut Sheets(Sheets(1).[c4].Value).Range("a" & lr1) End Sub

ملف شهادة مدرسية صالحة للمتوسط أو الثانوي أردت نشرها تعميم للفائدة وهي من إنجازي sadok 2018X2019.xlsm

السلام عليكم نزولا عند رغبة احد الاصدقاء برنامج تسجيل الاقساط اوتوماتيك نقوم بتسجيل بيانات العميل كاملة ثم نكبس على الاقساط نفتح لنا شاشة جديدة نكبس على تسجيل الاقساط فتنزل الاقساط اوتوماتيك عند دفع القسط نقوم بتحويل الحالة من لم يتم الدفع الى تم الدفع ثم تكبس على تحديث بعد الدفع نستطيع الحصول على كشف حساب للعميل أتمنى لكم الفائدة واتس أب 00962787787573 اقساط.accdb

السلام عليكم جميعا ، اقدم لكم برنامج الاول لمراقبة وسداد الاقساط...ونبذة عن البرنامج : 1:مجانى تماما 2:يصل تسجيل العملاء فيه الى5004عميل 3:الحجم خفيف جدا وهو مصمم عالاكسل وسهل الاستخدام وسريع ، 4:فورم دخول بكلمة مرور وهى (12345) ، 5:يحتوى على عدة صفحات منها : أ:الصفحة الرئيسية ، ب:صفحة العملاء "لتسجي بيانات العملاء فيها" ، ج:صفحة حالة العملاء لمراقبة حالة السداد وهى بحالات مثلا تكون الحالة : ١:اوشك على السداد اذا مر٢٧يوم من تاريخ اخر سداد للعميل باللون الاصفر ، ٢:متاخر اذا مر اكثر من٣٠يوم باللون البرتقالى ، ٣:متاخرجدا اذا مر اكثر من٦٢يوم باللون الاحمر ، ٤:وحالات اخرى منها لم يستحق ويقدم للشكوى ، د:صفحة بحث وترحيل "وفيها تقوم بالبحث عن العميل باى حرف من اسمه او من السلعة المباعة له او عنوانه او ان كان ضامن له ويتم سداد قسط العميل منهاوتستطيع تغيير قيمة القسط الافتراضية و لاغراض اخرى . . . " ، ع:صفحة عمليات السداد للعمليات المسددة ، غ:صفحة استعلام مختصر وتكون ب البحث بالكود "يتم جلب كل بيانات العميل بالمدفوع" ، ف:صفحتين فارغتين "ليقوم المستخدم باستخدامهما كيف يشاء" ، ق:صفحة كلمات المرور والصلاحيات "وتقوم فيها بالتعديل على كلمات المرور واعطاء صلاحيات الدخول لكل مستخدم و تغيير اسم المنشأة واسم المدير ليظهرا بالرئيسية وايضا اسم المستخدم يظهر بالرئيسية وفيها تقارير بسيطة للبرنامج ، واخيرا "الدال على الخير كفاعله" والسلام عليكم ورحمة الله وبركاته برنامج الأول للاقساط..xlsm.zip

أحسنت استاذ عمر بارك الله فيك

ربنا يكرم اصلك يا فندم وشكرا لردك الجميل

انا شخصياً كنت زيك مفتكر ان الاكسل مش اكثر من جدول وشوية كده هوو معادلات ضرب وجمع... إلى ان غطست في هذا البحر (لا بل المحيط الهائل) و ما زلت بكل تواضع لا اعرف (حسب تقديري) اكثر من 10% من المعلومات حول هذا البرنامج كل شيء اعرفه تم اكتسابه 1-بواسطة مشاهدة الفيديوهات (لم اتعلمه اكاديمياً في معهد أو جامعة) 2- التجارب التي أقوم بها على الاكسل يعجبني قول احد الشّعراء قل لمن يدّعي بالعلم معرفةً عرفت شيئاً و غابت عنك أشياءُ

السلام عليكم ورحمة الله تفضل الملف المرفق وفيه حل أول. مع إضافة جدول مساعد (ملون بالأخضر) خاص بقيم (العرض والارتفاع) لأنه لا يمكن العمل بالقيم النصية... بن علية حاجي Table.xlsx

السلام عليكم تم إلغاء الحماية عن الورقة (إزالة الكلمة السرية القديمة) ثم إعادة حمايتها بالكلمة السرية 123... إذا قمت بتغييرها فما عليك إلا إضافة هذه إلى الكود بدلا من 123 في الجزئية "Password:="123... بن علية حاجي طباعة ورقه محمية.xlsm

السلام عليكم كما وعدتكم .......... البرنامج جاهز ,,, وهو حسب نظام المملكة الاردنية الهاشمية تستطيعون التعديل عليه بما يتناسب مع منطقتكم من حيث الاسماء والاضافات البرنامج مفتوح المصدر وهو من تصميمي للتواصل والاستفسار عبر الواتس اب 00962787787573 اتمنى لكم الفائدة برنامج المحامي 2019 - Copy.rar

السلام عليكم بالاضافة لما تقدم به أ/ محمد أحمد لطفى فان استعلام تحديث سيفى بالغرض مهما كان حجم البيانات مثل هذا: UPDATE AccountsTbl SET AccountsTbl.AccountName = "الصندوق"; حيث: AccountsTbl 'اسم الجدول AccountName 'الحقل المراد التعديل عليه

وعليكم السلام الاستاذ الكريم عبداللطيف عاشت ايديك بارك الله فيك

استبدل هذه الاسطر من الكود Dim m%: m = 3: Dim Col%: Col = 5 Dim R%, T% بهذه Dim m as Long: m = 3: Dim Col as Long: Col = 5 Dim R as Long, T as Long لقد وضعت لك طريقة بواسطة المعادلات في مشاركة سابقة (في هذا الملف) لكن المشكلة أن البيانات كبيرة جداً (حواليي 5000 صف)مما يستغرق وقتاً كبيراً check_Salim1.xlsx

احسنت اخى

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

عليكم السلام استاذ عبداللطيف بارك الله فيك نشاط مميز جزاك الله خيرا

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

شكرا جزيلا لك أخ سليم

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

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

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

الملف الذي أرسلته معقد جداً لذا قمت بوضع ملف جديد مشابه لما تريد البيانات في الشيت 1 و النتيجة في الشيت2 الكود Option Explicit Sub eXtract_Data() Dim s_rg As Range Dim first$ Dim r%, c%, x r = 1: c = 1 Sheets("Sheet2").Range("a1").CurrentRegion.ClearContents Set s_rg = Sheets("Sheet1").Range("My_Rg").Find("*", _ after:=Sheets("Sheet1").Range("My_Rg").Cells(1, 1)) If Not s_rg Is Nothing Then first = s_rg.Address Do Sheet2.Cells(r, c) = s_rg.Value c = c + 1 If c = 9 Then r = r + 1: c = 1 End If Set s_rg = Sheets("Sheet1").Range("My_Rg").FindNext(s_rg) If s_rg.Address = first Then Exit Do Loop End If End Sub الملف مرفق saerch_and_copy.xlsm

بارك الله فيك استاذ سليم

أهلا بك محمد.. لكون أكسس لا يدعم الاستنساخ أثناء التشغيل فلابد من الإعتماد على مكونات ActiveX التي يوفرها أكسس... أحد هذه المكونات هو المكون Microsoft.Form.Frame يوفر هذا المكون سطح بيني(طبقة) قابل للاستنساخ؛ بين النموذج والمكونات الأخرى التابعة ل Microsoft.Form هذا مثال بسيط لطريقة إدراج الصور أثناء التشغيل حسب المفهوم السابق Photo.zip

اهلا بك اخى الكريم بالمنتدى -تفضل لك ما طلبت 1المطلوب.xlsx

وعليكم السلام 🙂 ماشاء الله ، مادام كل الشباب مشاركين ، فانا ادلو بدلوي كذلك 🙂 و جعفر

ممكن تجرب هذا الملف الكود Option Explicit Sub Give_Uniques() With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False End With With salim Dim m%: m = 3: Dim Col%: Col = 5 Dim R%, T% Dim Cel As Range, S_RG As Range Dim Find_RG As Range, A_RG As Range .Range("D3").CurrentRegion.ClearContents Set A_RG = .Range("A3").CurrentRegion.Columns(1) .Range("D3").Resize(A_RG.Rows.Count).Value = _ A_RG.Value .Range("D3").CurrentRegion.RemoveDuplicates 1, 0 Set S_RG = .Range("D3").CurrentRegion.Columns(1) For Each Cel In S_RG.Cells Set Find_RG = A_RG.Find(Cel, after:=A_RG.Cells(A_RG.Rows.Count)) R = Find_RG.Row: T = R Do .Cells(m, Col) = .Cells(R, 2): Col = Col + 1 Set Find_RG = A_RG.FindNext(Find_RG) R = Find_RG.Row If R = T Then Exit Do Loop m = m + 1: Col = 5 Next End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True End With End Sub الملف مرفق (فقط 90 كيلوبايت) check_salim.xlsm

اليك هذا لا اعرف من هو صاحبه لذلك ادعوا له اخفاء رسالة بعد عدد ثواني.mdb

بلا هناک طریقە اخری بدون نموذج و موجودە فی الموقع ستجدونە اذا تبحثون علیە والا غدا اذا ما انساە ساعطیکم لانی الان عم استخدم موبایل ولیس لدی لابتوب

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

جرب هذا الملف example_سليم.xlsm

جرب هذا الكود Option Explicit Sub compaire_columns() Dim sh1 As Worksheet, sh2 As Worksheet Dim First_rg1 As Range, Sec_rg1 As Range Dim First_rg2 As Range, Sec_rg2 As Range Dim m%, i% Set sh1 = Sheets("بيانات 1"): Set sh2 = Sheets("بيانات2") sh1.Range("A2").CurrentRegion.Columns(3).Offset(1).Resize(100, 2).Clear Set First_rg2 = sh2.Range("a2").CurrentRegion.Columns(1) Set Sec_rg2 = sh2.Range("a2").CurrentRegion.Columns(2) Set First_rg1 = sh1.Range("a2").CurrentRegion.Columns(1) Set Sec_rg1 = sh1.Range("a2").CurrentRegion.Columns(2) For i = 2 To First_rg1.Rows.Count If First_rg1.Cells(i) = First_rg2.Cells(i) Then First_rg1.Cells(i).Offset(, 2) = "مطابق" Else First_rg1.Cells(i).Offset(, 2).Interior.ColorIndex = 6 End If Next For i = 2 To Sec_rg1.Rows.Count If Sec_rg1.Cells(i) = Sec_rg2.Cells(i) Then Sec_rg1.Cells(i).Offset(, 2) = "مطابق" Else Sec_rg1.Cells(i).Offset(, 2).Interior.ColorIndex = 6 End If Next End Sub الملف مرفق المصنف2 _سليم.rar