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

هذه المرة لمحبي الرزنامات رزنامة سنوية Annual_Calendar.zip

السلام عليكم هكذا Sub Auto_Open() '' يتفعل عند الدخول للمصنف او عند تشغيل الكود Application.OnKey "%{F8}", "" End Sub لإعادة تفعيل الخاصيه كالتالي Sub Re_Ali() '' لإعادة تفعيل الخاصيه Application.OnKey "%{F8}" End Sub

lab.part001.rar تعديلات لكل الاخوه الافاضل اللى عنده اضافه او تعديل يتفضل عسى ان نستفيد جميعا وياريت لو حد من الاخوه الاعضاء يعمل لنا نموزج من خلاله يمكننا اضافه راس التقيرير والتذذيل لجميع التقارير مره واحد lab.part002.rar lab.part003.rar انا اسف اضريت اقسم البرنامج لانى مش عارف ارفعه مره واحده lab.part004.rar lab.part005.rar lab.part006.rar lab.part007.rar lab.part008.rar lab.part009.rar lab.part010.rar lab.part011.rar lab.part012.rar lab.part013.rar lab.part014.rar lab.part015.rar lab.part016.rar lab.part017.rar lab.part018.rar lab.part019.rar lab.part020.rar

لو سمحت اخى هناك ملف رقم 16 غير موجود حسب طلب برنامج الضغط

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

السّلام عليكم و رحمة الله و بركاته أخي الكريم " مصطف محمود مصطفى " الملف المعدّل من طرف أستاذنا القدير " ياسر العربي " يعمل عندي بشكل أكثر من الطبيعي فائق إحتراماتي

السلام عليكم او بالكود التالي لاثراء الموضوع Sub Ali_Rng_Find() Dim Rng As Range, Rn As Range, R As Range Set Rn = [B3] '' خلية شرط البحث For Each Rng In ActiveSheet.UsedRange If Rng.Value = Rn.Value And IsDate(Rn) And _ Rng.Address <> Rn.Address Then If Not Rng Is Nothing Then If R Is Nothing Then _ Set R = Rng Else Set R = Union(R, Rng) End If Next Rng If Not R Is Nothing Then R.Interior.ColorIndex = 3: R.Activate Set Rng = Nothing: Set Rn = Nothing: Set R = Nothing End Sub

أخي الحبيب أبا الحسن والحسين كيف أصبحت ؟ أتمنى أن تكون في أحسن حال وعال العال جرب الكود التالي في حدث الفورم Private Sub UserForm_Initialize() Dim WS As Worksheet For Each WS In ThisWorkbook.Sheets If Left(WS.Name, 1) = "R" Or Left(WS.Name, 1) = "C" Then ComboBox1.AddItem WS.Name Next WS End Sub

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

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

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

تعلم أكسس 2007 | الفصل الأول : بدء العمل مع أكسس

السلام عليكم دالة استخراج تاريخ الميلاد او النوع او المحافظة من الرقم القومي ثلاثة معطيات بدالة واحدة Option Explicit ' بسم الله الرحمن الرحيم ' ******************** ' دالـــــــــــــــة ' Kh_Date_Sex_Province ' ( استخراج تاريخ الميلاد او النوع (ذكر - انثى ' او المحافظة من الرقم القومي '============================================== ' MyTest ' اذا كانت = 1 تقوم باستخراج تاريخ الميلاد ' اذا كانت = 2 تقوم باستخراج النوع ' اذا كانت = 3 تقوم باستخراج المحافظة '---------------------------------------------- ' MyProvinces في متغير الجدول ' العمل لم يستكمل بعد ' يمكنك إضافة المحافظات الاخرى الغير موجودة ' او تعديل الموجود في حالات الخطأ ' بنفس الطريقة الرقم اولا ثم "/" ثم اسم المحافظة ' : مثال على ذلك ' "01/القاهرة" '============================================== '----------------------------------------------------------------- Function Kh_Date_Sex_Province(MyNumber As Variant, MyTest As Byte) Dim MyProvinces As Variant Dim r As Integer Dim yy As String Dim ty As String * 1 Dim d As String * 2, m As String * 2, y As String * 2 _ , x As String * 2, xx As String * 2 '============================================== ' يمكنك إضافة المحافظات الاخرى الغير موجودة ' او تعديل الموجود في حالات الخطأ MyProvinces = Array("01/القاهرة", "02/الإسكندرية", "12/الدقهلية", "13/الشرقية" _ , "14/القليوبية", "15/كفر الشيخ", "16/الغربية", "17/المنوفية", "18/البحيرة" _ , "19/الإسماعيلية", "21/الجيزة", "22/بني سويف", "24/المنيا", "25/أسيوط" _ , "26/سوهاج", "27/قنا", "28/أسوان", "29/الأقصر", "33/مطروح") '============================================== Kh_Date_Sex_Province = "" On Error GoTo 1 If Len(Trim(MyNumber)) = 0 Then GoTo 1 End If If Not IsNumeric(MyNumber) Or Len(MyNumber) <> 14 Then Kh_Date_Sex_Province = "Error_MyNumber" GoTo 1 End If If MyTest = 1 Then d = Mid(MyNumber, 6, 2) m = Mid(MyNumber, 4, 2) y = Mid(MyNumber, 2, 2) ty = Left(MyNumber, 1) Select Case ty Case "2": yy = y Case "3": yy = "20" & y Case Else: yy = "" End Select If yy <> "" Then Kh_Date_Sex_Province = DateSerial(yy, m, d) ElseIf MyTest = 2 Then If Left(Right(MyNumber, 2), 1) Mod 2 = 1 Then _ yy = "ذكر" Else yy = "انثى" Kh_Date_Sex_Province = yy ElseIf MyTest = 3 Then x = Mid(MyNumber, 8, 2) For r = LBound(MyProvinces) To UBound(MyProvinces) xx = MyProvinces(r) If x = xx Then Kh_Date_Sex_Province = Right(MyProvinces(r), Len(MyProvinces(r)) - 3) Exit For End If Next End If 1: End Function بالنسبة لمعطيات المحافظات لم تستكمل بعد ويمكنك اضافة المحافظات المتبقية حسب ما شرحت بالكود خبور خير دالة استخلاص تاريخ الميلاد و النوع و المحافظة من الرقم القومي.rar

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

السلام عليكم ورحمة الله وبركاته أحبائى وأساتذتى ومعلمينى فى هذا الصرح العلمى الهائل تحية طيبة وبعد أقدم لكم اليوم مجموعة رائعة من الأيقونات زات الجودة العالية أرجوا من الله أن تنال إعجابكم http://www.mediafire.com/download/42x3exq2c119cvo/1.rar http://www.mediafire.com/download/97cazvonq76t7r5/2.rar#1 http://www.mediafire.com/download/3da8dafesiy96hc/3.rar http://www.mediafire.com/download/byhgi1eu2u9ou29/4.rar http://www.mediafire.com/download/31yspi92357332b/5.rar http://www.mediafire.com/download/mydc1fc09z1kbj7/6.rar http://www.mediafire.com/download/ewm23d4geccddex/7.rar تقبلوا خالص تحياتى وتقديرى

أخي الكريم مفتاح أهلاً بك في المنتدى ونورت بين إخوانك يرجى تغيير اسم الظهور للغة العربية إليك الملف التالي فيه دالة معرفة تقوم بالمطوب إن شاء الله كما يوجد خاصية البحث في المنتدى وستجد موضوعات بهذا الخصوص كثيرة .. تقبل تحياتي Split Compound Names UDF Function.rar

شوف كدا ياريس والله الواحد بيكتشف الحاجات دي منكم يعني احنا هنا الكل مستفاد Version office.rar

ههههههههههههههههههههه ماهو ده اللى حيجننى فين البرنامج ههههههههههههههههههههههههههههههههههه أصلا ردود الأعضاء جعلنى اشك في بصرى وفى نفسى

Sub Ali_Rng_Find2() Dim Rng As Range, Rn As Range, R As Range Set Rn = [B3] '' خلية شرط البحث Sheets("ورقة1").Range("E3").CurrentRegion.Interior.Pattern = xlNone For Each Rng In ActiveSheet.UsedRange If Rng.Value = Rn.Value And IsDate(Rn) And Rng.Address <> Rn.Address Then If Not Rng Is Nothing Then If R Is Nothing Then Set R = Rng Else Set R = Union(R, Rng) End If Next Rng If Not R Is Nothing Then R.Interior.ColorIndex = 3: R.Activate Set Rng = Nothing: Set Rn = Nothing: Set R = Nothing End Sub حل رائع أخى الكريم العيدروس لو تسمح بالاضافة السابقة ( ازالة اللون عن الخلايا المحددة باللون الأحمر سابقا و تلوين الخلايا المحددة حاليا فقط )

رائع بارك الله فيك ووفقك في الدنيا والآخرة

اخي الغالي تفضل Application.Visible = False هذا السطر لجعل برنامج الاكسيل غير مرئي اما تمسحها او تعكسها Application.Visible = True وهذا الكود Dim S As Worksheet Const wsKeep As String = "Sheet7" Worksheets(wsKeep).Visible = True For Each S In Worksheets If S.Name <> wsKeep Then S.Visible = xlSheetVeryHidden Next S يعمل علي اظهار الشيت 7 ويقوم باخفاء الباقي وانت لا تحتاح هذا فنستبدلة بهذا Sheet7.Activate مجرد كود لتنشط الشيت فقط وهكذا مع كل الاكواد مشكور اخي العزيز الكريم عبد العزيز البسكري لدعمك الجميل لنا كل الشكر والتقدير لك اخي الغالي ومرة اخري اخي الغالي يرجى مراجعه المرفق جيدا لعلك فتحت نفس الملف الموجود عندك لتشابه الاسماء بين الملفين وشكرا

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

تفضل اخي شاشة دخول شيت كنترول برقم سرى - سعيد بيرم.rar

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

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

انسخ هذه المعادلة الى الخلية G8 ثم اسحب يسارا و نزولاً =IF($G8<>H$7,"",COUNTIF($B$2:$B$25,$G8))

السلام عليكم حط الشروط اول الكود وجرب تنفيذ الكود Sub Ali_Sort() Dim Cn_A As String Dim Rn As Range, My_Sort As Range Dim Va_Sp 'xxxxxxxxxxxxxxxxx ' نطاق شروط احرف الفرز Set Rn = [A4:A13] ' نطاق المراد فرز بياناته Set My_Sort = [C1:C13] 'xxxxxxxxxxxxxxxxx With Application .ScreenUpdating = False Cn_A = Join(.Transpose(.Index(Rn.Value, 0)), ",") .AddCustomList ListArray:=My_Sort Va_Sp = .GetCustomListNum(My_Sort.Value) With ActiveSheet.Sort .SortFields.Clear .SortFields.Add Key:=My_Sort, Order:=xlAscending, CustomOrder:="""" & Cn_A & """" .SetRange My_Sort .Apply End With .DeleteCustomList Va_Sp .ScreenUpdating = True End With Set Rn = Nothing: Set My_Sort = Nothing End Sub

السّلام عليكم و رحمة الله و بركاته إحدى الحلول البسيطة بواسطة التّنسيق الشّرطي و تلوين خلية التّاريخ محل البحث ..ربما تفي بالعرض فائق إحتراماتي كود انتقال.rar

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

الموضوع بسيط إذاً هتلغي الحماية عن طريق صندوق الاختيار بوضع القيمة True بحيث يلغي الحماية المرتبطة بالنطاق وفي آخر الكود ترجع الحماية بتغيير القيمة إلى False Sub الصف_كل() [BK3].Value = "TRUE" Range("h1").Select ActiveCell.FormulaR1C1 = "1" ActiveSheet.PageSetup.PrintArea = "$h$3:$O$36" ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True Do ActiveCell = ActiveCell + 2 ActiveWindow.SelectedSheets.PrintPreview Loop Until ActiveCell.Value >= Range("N1").Value Range("A1").Select [BK3].Value = "FALSE" End Sub بس خلاص .. متنساش تغير كلمة PrintPreview إلى PrintOut أي طلب جديد ليس له علاقة بالموضوع يرجى طرحه في موضوع مستقل

شكرا لكم اخي سليم عمل جميل

أستاذ سليم المحترم هدية قيمة ورائعة ...شكرا على هذا العمل الهام تقبل تحياتي.

اخى الحبيب مرحبا بمرورك الكريم عن طريق Insert ثم Picture ثم البحث عن الأيقونة المراد نقلها داخل الإكسيل وشكرا أشكرك على مرورك الكريم أخى الفاضل أبو ليالى وشكرا لدعائك الطيب

انظر الصورة

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

اخي مشاكس مانوع الاوفيس عندك 2003 ام 2007 ؟

ممكن توضيح اكثر اخ محمد ؟

السلام عليكم كثر الطلب على كود يعيد تحجيم النماذج لتتناسب مع حجم شاشة المستخدم وهذا الكود قد وضعته في ملف واحد وهي عبارة عن مثالين داخل ملف أكسس واحد عند فتح البرنامج إفتح النموذج الي اسمه : frmwelcome وهذا للمثال الأول أما للمثال الثاني افتح النموذج الي اسمه : frmwelcome2 وستجد ما يسركم من الكودات عسى الله ينفع بها الجميع والسلام عليكم Example_1+2_ For changing ScreenDPI.rar

السلام عليكم ورحمة الله وبركاته فورم لاجراء قرعة لبيانات معينة وهوطلب لاحدهم في الرابط ادناه http://www.officena.net/ib/index.php?showtopic=55244 جعلته هنا لتعم الفائدة ملاحظة : تم اضافة امكانيات اخرى لهذا المرفق المرفق 2003 قرعة.rar ================================================================= وردني هذا السؤال على الخاص المرفق 2003 قرعة متعددة الاختيار.rar

السلام عليكم آمل تجربة المرفق و اخباري بالنتيجة حيث انني لم اجربة حماية_مصنف.rar