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

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

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

جرب هذا التعديل 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

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

السّلام عليكم و رحمة الله و بركاته إحدى الحلول البسيطة بواسطة التّنسيق الشّرطي و تلوين خلية التّاريخ محل البحث ..ربما تفي بالعرض فائق إحتراماتي كود انتقال.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

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