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

هذه المرة لمحبي الرزنامات رزنامة سنوية 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

التغيير : ان تسجيل المكتبات سيكون داخل مجلد syswow64 بدلا من system32 ولكن ستلاحظ ان قوة الامان اشد خاصة في الاصدار 8 وما فوق

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

اعرض الملف h عند كتابة التاريخ في الخلية B3 بان يبحث عنها في العمود E والذهاب اليها وكذلك البحث في الصف 3 كود انتقال.rar كود انتقال.rar صاحب الملف أسماء تمت الاضافه 02 ديس, 2015 الاقسام قسم الإكسيل

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 حل رائع أخى الكريم العيدروس لو تسمح بالاضافة السابقة ( ازالة اللون عن الخلايا المحددة باللون الأحمر سابقا و تلوين الخلايا المحددة حاليا فقط )

وعليكم السلام ورحمة الله وبركاتة وبعد الشكر للاخ العزيز رمهان على ما يقوم به من جهود واضحه وبعد اخذ الاذن منه اتقدم بهذه المساهمه المتواضعه والتي ارجو ان ينفع الله بها Function Sijil(a, b) As String If Len(a) > 0 Then MsgBox a & "/" & b Else MsgBox "" End If End Function مع استبدال msgbox بالمكان الذي تريد ان يظهر فيه الناتج

أخي الحبيب ياسر كان معاااااااااااااااايا الكتالوج بس مش عارف راااااااح مني فين .. شكلك قلبتني في الكتالوج !! اطلع بالكتالوج يا عربي وبلاش الحركات النص كوم دي ..خليك في الحركات دوت كوم أحسن ربنا يوفقك في التاتش إن شاء الله

أخي وحبيبي إبراهيم شفاكم الله وعافاكم وألف لا بأس عليك لا بأس طهور إن شاء الله أسأل الله العظيم رب العرش العظيم أن يشفيك أسأل الله العظيم رب العرش العظيم أن يشفيك أسأل الله العظيم رب العرش العظيم أن يشفيك أسأل الله العظيم رب العرش العظيم أن يشفيك أسأل الله العظيم رب العرش العظيم أن يشفيك أسأل الله العظيم رب العرش العظيم أن يشفيك أسأل الله العظيم رب العرش العظيم أن يشفيك تقبل وافر تقديري واحترامي

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

اخي الغالي تفضل 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 مجرد كود لتنشط الشيت فقط وهكذا مع كل الاكواد مشكور اخي العزيز الكريم عبد العزيز البسكري لدعمك الجميل لنا كل الشكر والتقدير لك اخي الغالي ومرة اخري اخي الغالي يرجى مراجعه المرفق جيدا لعلك فتحت نفس الملف الموجود عندك لتشابه الاسماء بين الملفين وشكرا

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

فعلاً الكود لاينفذ شيء سأعمل عليه لاحقاً ان شاء الله

جرب هذا التعديل Sub Ali_Merg_Data1() Dim R As Range Dim Rng As Range Dim My_r As Range Dim X_r As Double Dim Ing As Variant On Error Resume Next For Each R In Range("A6:A" & Ali_Last(Range("A6:A2000"), "*")) If R <> "*" Then If Not R Is Nothing Then If Rng Is Nothing Then Set Rng = R Else Set Rng = Union(Rng, R) End If End If Next R 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx If Not Rng Is Nothing Then For Each Ing In Split(Ali_My_Rng(Rng.Offset(0, 5), Rng.Offset(0, 7), Rng.Offset(0, 8)), ",") Set My_r = Range(Ing) X_r = Alr_Cn(My_r) With My_r .ClearContents .Merge .Value = X_r End With Next End If On Error GoTo 0 Set Rng = Nothing: Set R = Nothing Set My_r = Nothing 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx End Sub Private Function Alr_Cn(R As Range) Dim i Dim Sm Dim Sn As String With R For i = 1 To .Rows.Count If Not IsNumeric(.Cells(i, 1)) Then Sm = .Cells(1, 1) Else Sm = Sm + .Cells(i, 1) End If Next i If Sm Then Alr_Cn = Sm End With End Function Private Function Ali_Last(Rnge As Range, F_Tx$) Dim vv Application.ScreenUpdating = False For vv = Rnge(Rnge.Count).Row To Rnge(1).Row Step -1 If Cells(vv, Rnge.Column) = F_Tx Then Ali_Last = vv Exit Function End If Next vv Application.ScreenUpdating = True End Function Private Function Ali_My_Rng(ParamArray Rngs() As Variant) As String Dim N As Long Dim R As Range Dim T As String For N = LBound(Rngs) To UBound(Rngs) If Not Rngs(N) Is Nothing Then For Each R In Rngs(N).Areas T = T & "," & R.Address Next R End If Next N Ali_My_Rng = Mid(T, 2, Len(T)) End Function

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

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

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

أخي الكريم احمد أهلاً ومرحباً بك في المنتدى ونورت بين إخوانك تفضل الكود يوضع في حدث المصنف ويقوم بحماية جميع الأوراق بكلمة السر 1 اضغط Alt + F11 للدخول إلى محرر الأكواد ثم انقر دبل كليك في نافذة المشروع على ThisWorkbook ثم ضع الكود التالي .. احفظ الملف بصيغة Xlsm (لمزيد من التفاصيل يرجى الإطلاع على رابط موضوع بداية الطريق لانقاذ الغريق من هنا) تفضل Private Sub Workbook_Open() Dim WS As Worksheet For Each WS In ThisWorkbook.Sheets WS.Protect 1 Next WS End Sub تقبل تحياتي

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

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

اخي الكريم ابو عبدالرحمن المرفق الاول توضيح والاخر ملفك وبه الكود وزر ترحيل انقر عليه لتشغيل الكود تقبل تحياتي وشكري توضيح.rar برنامج الوزارات مرتب على واجهة تحتوي على ازرار_111.rar

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

سلمت يمينك أخى الحبيب / سليم جعله الله فى ميزان حسناتك

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

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

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

انظر الصورة

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

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

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

رابط جديد .. اتمنى ان يعمل بكفاءة كنترول ابتدائى

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

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

السلام عليكم هذا مثال لما اوردته باستخدام في مشاركتي السابقة عن استخدام سلكت كوس غير معطياتك كعميل او مورد Sub kh_AddItem(nSh As String) Dim MyRng As Range Dim R As Integer Dim ContRow As Long, i As Long Dim tFindNum As String Dim dt1 As Date, dt2 As Date '------------------------- On Error GoTo 1 '------------------------- Set MyRng = Sheets(nSh).Range(MyTopColmnRng) '------------------------- With MyRng ContRow = .Worksheet.Cells(Rows.Count, .Column).End(xlUp).Row - .Row End With If ContRow = 0 Then Exit Sub '------------------------- ' اسم الحساب المطلوب tFindNum = LCase(saad1.ComboBox1.Value) '------------------------- ' التواريخ dt1 = CDbl(CDate(saad1.ComboBox2)) dt2 = CDbl(CDate(saad1.ComboBox3)) '------------------------- With MyRng.Offset(1, 0) For R = 1 To ContRow Select Case .Cells(R, dColmn).Value2: Case dt1 To dt2 If LCase(.Cells(R, MyColmnFind)) Like tFindNum Then '''''''''''''''''''''''''''''''' 'مثلا هذه الاعمدة مطلوبة في كل الحسابات Cells(ii, "B").Resize(1, 6).Value = .Cells(R, 1).Resize(1, 6).Value ' المعيار اسم الورقة Select Case .Worksheet.Name 'باقي الاعمدة وهي اربعة نختار فيها مانريده Case "مشتريات", "م.مبيعات" Cells(ii, "H").Resize(1, 4).Value = Array(.Cells(R, 7).Value, .Cells(R, 8).Value, "", .Cells(R, 9).Value) Case "مبيعات", "م.مشتريات" Cells(ii, "H").Resize(1, 4).Value = Array(.Cells(R, 7).Value, .Cells(R, 8).Value, .Cells(R, 9).Value, "") Case "خزينة" Cells(ii, "H").Resize(1, 4).Value = Array("", "", .Cells(R, 7).Value, .Cells(R, 8).Value) End Select '''''''''''''''''''''''''''''''''''' ii = ii + 1 End If End Select Next End With '------------------------- 1: Set MyRng = Nothing End Sub المرفق 2003 تقرير حساب بين فترات مأخوذ من عدة اوراق1.rar

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