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

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

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

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

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

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

السلام عليكم ورحمة الله وبركاته أحبائى وأساتذتى ومعلمينى فى هذا الصرح العلمى الهائل تحية طيبة وبعد أقدم لكم اليوم مجموعة رائعة من الأيقونات زات الجودة العالية أرجوا من الله أن تنال إعجابكم 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 بالمكان الذي تريد ان يظهر فيه الناتج

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

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

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

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

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

جرب هذا التعديل 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 للطباعة الكلمة الأولى للمعاينة فقط والثانية للطباعة أرجو أن يكون المطلوب

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

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

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

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

انظر الصورة

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

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

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

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