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

السلام عليكم ورحمة الله وبركاته أساتذتى واخوتى اليوم أقدم لكم كودا منقولا بعد تعديله وترجمته لتحديد الفترة التجريبية لملف اكسل . فكرة الكود : عند فتح الملف يتم انشاء ملف نصى دون شعور المستخدم يتم تحرير تاريخ ووقت بداية فتح الملف فى الملف النصى بقورمات معين كما يظهر فى الكود بعد ذلك يقارن اكسل تاريخ اليوم مع التاريخ المحرر فى الملف النصى حتى تنتهى أيام الفترة التجريبية فاذا انتهت الفترة التجريبية يتم الآتى : 1 - اغلاق ملف الاكسل و عدم قدرتك على فتحه 2 - انشاء مجلد جديد تجد فيه : ملف نصى نشكرك فيه على تجربة المنتج وأوراق العمل فى الملف الأصلى تحفظ لك كل على حدة فى ملف مستقل الكود وعليه الشرح : Option Explicit Private Sub Workbook_Open() Dim StartTime#, CurrentTime# '---------------------------------------------------------- ' اعداد الفترة التجريبية كالتالى ' Integers 1, 2, 3,30 ,365 ...etc = number of days use ' 1/24 = 1hour , 1/48 = 30Mins , 1/144 = 10Mins use Const TrialPeriod# = 30 ' 30 days trial '---------------------------------------------------------- 'انشاء ملف مبهم المسار والاسم لتحديد بداية الفترة التجريبية Const ObscurePath = "C:\" Const ObscureFile = "Test File Log.Log" 'اذا كان الملف ذو المسار والاسم المحدد فارغا فان If Dir(ObscurePath & ObscureFile) = Empty Then ' بداية الوقت = تاريخ اليوم والوقت الحالى بالتنسيق الخاص StartTime = Format(Now, "#0.#########0") 'جواب الشرط : افتح الملف ذو المسار والاسم المحدد Open ObscurePath & ObscureFile For Output As #1 'تابع جواب الشرط : اكتب فى الملف بداية الوقت Print #1, StartTime Else ' فى حالة عدم تحقق الشرط فان 'افتح الملف ذو المسار والاسم للتحقق من وقت البداية Open ObscurePath & ObscureFile For Input As #1 Input #1, StartTime ' الوقت الحالى = تاريخ اليوم والوقت الحالى بالتنسيق الخاص CurrentTime = Format(Now, "#0.#########0") 'اذا كان الوقت الحالى أقل من بداية الوقت + الفترة التجريبية If CurrentTime < StartTime + TrialPeriod Then Close #1 ' غلق الملف المبهم قيد الاستعمال Exit Sub ' الخروج من الاجراء Else ' فى حالة عدم تحقق الشرط If [A1] <> "Expired" Then ' اذا كانت الخلية لا تساوى النص "Expired" فان ' رسالة للمستخدم بانتهاء الفترة التجريبية وعدم صلاحية الملف للاستعمال MsgBox "Sorry, your trial period has expired " & vbLf & _ "your data will now be extracted and saved for you..." & vbLf & "" & vbLf & _ "This workbook will then be made unusable." Close #1 ' غلق الملف المبهم قيد الاستعمال SaveShtsAsBook ' استدعاء كود حفظ البيانات للمستخدم [A1] = "Expired" ActiveWorkbook.Save ' حفظ الملف Application.Quit ' اغلاق اكسل نهائيا ElseIf [A1] = "Expired" Then ' اذا كانت الخلية تساوى النص "Expired" فان Close #1 ' غلق الملف المبهم قيد الاستعمال Application.Quit ' اغلاق اكسل نهائيا End If End If End If Close #1 End Sub Sub SaveShtsAsBook() ' كود حفظ بيانات المستخدم بحيث كل شيت يحفظ فى ملف منفصل Dim MyFilePath As String, Sheet As Worksheet, SheetName As String, N As Integer MyFilePath = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) With Application .ScreenUpdating = False ' ايقاف تحديث الشاشة .DisplayAlerts = False ' ايقاف التنبيهات On Error Resume Next ' فى حالة الخطأ تجاهله MkDir MyFilePath ' انشاء مجلد فارغ باسم الملف For N = 1 To Sheets.Count ' حلقة تكرارية بعدد أوراق الملف Sheets(N).Activate ' تنشيط الشيت SheetName = ActiveSheet.Name ' اعتبار المتغير = اسم الشيت Cells.Copy ' نسخ كامل الشيت Workbooks.Add (xlWBATWorksheet) ' انشاء ملف اكسل جديد With ActiveWorkbook ' مع الملف النشط With .ActiveSheet ' مع الشيت النشط .Paste ' لصق البيانات فيه .Name = SheetName ' تسمية الشيت النشط [A1].Select ' تنشيط الخلية End With ' حفظ الملف النشط فى المجلد باسم الشيت النشط .SaveAs FileName:=MyFilePath & "\" & SheetName & ".xls" ' غلق الملف النشط مع حفظ البيانات .Close SaveChanges:=True End With .CutCopyMode = False ' تفريغ الذاكرة العشوائية Next ' الشيت التالى End With ' انشاء ملف نصى به تعليمات هامة للمستخدم بداخل المجلد Open MyFilePath & "\Read Me.log" For Output As #1 ' كتابة الأسطر التالية فى الملف النصى Print #1, "Thank you for trying out this product." Print #1, "If it meets your Requirements, visit :" Print #1, "http://www.officena.com " Print #1, "to purchase the full version..." Print #1, "" Print #1, " --------- Regards -------------" Print #1, "Mokhtar Hussien officena team" Close #1 ' غلق الملف النصى End Sub الكود يوضع فى حدث Workbook بامكانك تعديل مسار الملف النصى وبامكانك تعديل الفترة التجريبية الى مدة زمنية محددة أو شهور أو سنوات كما يتضح فى التعليق المحرر فى الكود لتجربة الكود : اذهب الى الملف النصى ستجد رقما زى كده : 42298.7085185185 ده هو وقت تشغيل الملف نقص الفترة التجريبية المحددة فى الكود من الرقم الصحيح 42298. يعنى نخلية 42250 مثلا ونحفظ الملف النصى على كدة روح افتح الملف هتلاقى الملف يقلك لا شكرا على كده وهحفظلك بياناتك عشان متزعلش مرفق للتجربة : Trial Version Ended 30 days.rar

أخى محمد انظر الرابط http://www.officena.net/ib/topic/64284-من-يريد-حماية-متميزة-لبرنامجه-يتفضل/ لأخينا ياسر العربى وده كود منع فتح الملف إذا تم نقله أو تغيير إسمه ومنع حفظه بإسم جديد ' Private Sub Workbook_Open() ' Dim MyPath As String ' Dim MyFlName As String ' ' MyPath = "Z:\SHARED GENERAL" ' MyFlName = "TEST-1.xls" ' If ThisWorkbook.Path <> MyPath Then ' Application.DisplayAlerts = False ' ThisWorkbook.Close ' End If ' If ThisWorkbook.Name <> MyFlName Then ' Application.DisplayAlerts = False ' ThisWorkbook.Close ' End If ' End Sub ' Private Sub workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) ' Dim lReply As Long ' ' If SaveAsUI = True Then ' lReply = MsgBox("عفواً لايمكنك حفظ هذا الملف بإسم جديد .. هل تريد حفظ الملف بإسمه الحالي ؟", vbQuestion + vbOKCancel) ' Cancel = (lReply = vbCancel) ' If Cancel = False Then Me.Save ' Cancel = True ' End If ' End Sub عدل فى الكود اسم و مسار الملف كما تشاء فاذا كان اسم الملف ومسار الملف غير المثبت فى الكود لن يفتح الملف

أخي الكريم 66 محمود (قال يعني إحنا قادرين على محمود واحد ..لما نقابل 66 محمود مرة واحدة) سأقوم بتناول حلول مختلفة واختر منها ما يناسبك .. قمت بإنشاء مصنفين واحد باسم Test والثاني باسم Sample .. في المصنف الثاني قمت بوضع قيمة في الخلية A1 ، وفتحت المصنف الأول ووضعت معادلة في الخلية G7 كما بالصورة إذا نظرت لشريط المعادلات ستجد علامة يساوي يليها علامتين تنصيص مفردة بهذا الشكل ' ... وما بين العلامتين يوجد مسار المصنف المسمى Sample بالكامل ثم \ ثم اسم المصنف ما بين أقواس [ ] ثم يليه مباشرةً ورقة العمل الأولى في المصنف المصدر ...وأخيراً بعد علامة التنصيص المفرة الثانية ' يوجد علامة تعجب ! ثم الخلية المصدر A1 الحل الذي قدمه أخونا الحبيب مختار حسين ..الخطوات كما بالصورة الحل المقدم صحيح 100% ولكن لكي تكتمل الخطوات لابد من تغيير في إعدادات الإكسيل ، من خلال خيارات الإكسيل Excel Options ثم انقر على Trust Center ثم Trust Center Settings ثم اختر من القائمة في الجهة اليسرى External Content واختر الخيار الأول في القسمين الظاهرين في النافذة لديك احفظ وأغلق المصنف و قم بتجربة المصنف المسمى Sample بأن تضع أي قيمة جديدة في الخلية A1 واحفظ المصنف وأغلقة ، ثم قم بفتح المصنف Test ستجد أن البيانات يتم تحديثها ************************ حل آخر بعيداً عن تغيير الإعدادات بكود يوضع في حدث المصنف Test بهذا الشكل ، ويقوم بتحديث الروابط للملفات الخارجية Update All External Links Private Sub Workbook_Open() 'UpdateLinks All Links '--------------------- Dim MyLink As Variant For Each MyLink In ActiveWorkbook.LinkSources(xlExcelLinks) ActiveWorkbook.UpdateLink Name:=MyLink, Type:=xlExcelLinks Next MyLink End Sub لتجربة الكود والتأكد من عمله قم بإرجاع الإعدادات في الصورة الأخيرة إلى الخيار الثاني في القسمين prompt user about Data Connections Prompt user on automatic update for workbook links احفظ المصنف المسمى Test بعد وضع الكود في حدث المصنف ... اذهب للمصنف المسمى Sample وعدل الخلية A1 واحفظ وأغلق افتح المصنف Test لتجد أنه تم تحديث البيانات بدون تغيير في الإعدادات ..فقط بكود يوضع في حدث المصنف أرجو أن أكون قد وفقت في توصيل المعلومة بشكل بسيط يسهل فهمه الرجاء تغيير اسم الظهور للغة العربية والإطلاع على رابط التوجيهات في الموضوعات المثبتة في المنتدى لمعرفة كيفية التعامل بشكل أفضل مع المنتدى تقبل تحياتي

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

تم بحمد الله وفضله ثنائيه رائعه من العمل والعلم اخي ياسر واخي مختار زادكم الله من علمه وفضله

مبروك .. أنت لها .. الله يعينك

السلام عليكم جميعا ورحمته الله وبركاته أخى الفاضل الاستاذ // رضا راغب أهلا وسهلا بك أخى الكريم بين إخوانك المتميزين خلقا وعلما وأدبا وبعد إذن اخى الحبيب // ياسر خليل " أبو البراء " وإثراءا للموضوع إليك هذا الكود وبإذن الله تعالى ستجد حلا للموضوع جزاكم الله خيرا وبارك فيكم Private Const cRunWhat = "Tarhil_Values" Private RunWhen As Double, Arr() As Range, CurIndex As Long Public Sub StartTimer() Dim A As Areas, I As Long If RunWhen > 0 Then MsgBox "The Process Is Already Running" Exit Sub End If Set A = Sheets("Sheet1").Columns("A").SpecialCells(2, 1).Areas ReDim Arr(1 To A.Count) For I = 1 To A.Count Set Arr(I) = A(I).CurrentRegion Next I CurIndex = 0 RunWhen = Now + TimeSerial(0, 0, 10) Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, Schedule:=True End Sub Public Sub StopTimer() On Error Resume Next Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, Schedule:=False RunWhen = -1 MsgBox "Transferring Data Will Be Turned Off" End Sub Private Sub Tarhil_Values() CurIndex = CurIndex + 1 If CurIndex > UBound(Arr) Then StopTimer Exit Sub End If Arr(CurIndex).Copy Sheets("Sheet2").Cells(Arr(CurIndex).Row, "C") Application.CutCopyMode = False RunWhen = Now + TimeSerial(0, 0, 10) Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, Schedule:=True End Sub

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

الكود يعمل بطريقة ممتازة انتبه الا تضع اي مسافة فارغة قبل الاسم انظر المرفق talween 1.zip

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

جرب المرفق التالي Prog1000.rar

تفضل ,ولى الامر .rar

أخى العزيز ياسر موضوع استخدام Integer أو Long بيكون حسب البيانات المطلوبة كما بالجدول التالى .. ويفضل لو كان حاجة خفيفة تستعمل الأخف وهو Integer الكلام ده مش بيفرق كتير هنا لكن لو ها تبنى قاعدة بيانات كبيرة بالاكسس او احدى برامج البيانات الاخرى بيقرق كتير لأنه بيحجز مساحة لكل حقل بيانات حسب المتغير المطلوب منه يعنى مثلا لو قاعدة بيانات بها من النوع Integer هاتكون المساحة/ الحجم المطلوب لقاعدة البيانات نصف المطلوب للمتغير Long عن كل سطر من البيانات VB Alias Size Range Integer 32 bits (4 bytes) -2,147,483,648 to 2,147,483,647 Long 64 bits (8 bytes) -9,223,372,036,854,775,808 to 9,223,372,036,854,775,807

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

السلام عليكم ورحمة الله وبركاته التنسيقات الرقمية المخصصة تنسيق الارقام السالبة باللون الاحمر ووضعها بين قوسين تقبلوا منى تحياتى وتقديرى تنسيق رقمى سالب(1).rar

تصميم موقع باكسبرشن ويب http://www.youtube.com/watch?v=Ytj9WgTjnUA

بسم الله الرحمن الرحيم سابقا كنت ابحث عن طريقة اعرض بها منتجا علي الاكسيل بمعلومات كاملة عنه وهي بيانات المنتج وصورته فكان من السهل الوصول للبيانات بمعادلات بسيطة وسهلة اما صورة المنتج فكانت مشكلتي حتى وجدت هذا الكود الرائع فاحببت ان افيدكم لان المعظم سيحتاجه لنفس غرضي او لوضعه مثلا كصورة مستخدم لكل مستخدم لبرنامج الاكسيل وغيرها اليكم المثال يوجد فولدر داتا وهو الذي يحتوي علي كل الصور التي ستعرض في الملف كل ما عليك هو ان تدخل علي شيت اتنين وتملاء بياناتك الكود والصنف والحجم والسعروالملاحظات وتدخل علي فولدر داتا وتضع فيه صور منتجاتك وتعمل لها اعادة تسمية ولكل كود منتج تكتبه علي الصورة الخاصة به وتدخل علي الشيت الاول وتكتب الكود الذي ترغب في رؤية بياناته اترككم لتجربوه بنفسكم ياسر العربي image.rar

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

ألف مليون مبروك أخى الحبيب / خالد الرشيدى على الترقية المستحقة مع مزيد من التقدم والرقى

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

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

بارك الله فيك أخي الحبيب مختار فقط أضف سطر آخر للحفاظ على تنسيقات ورقة العمل قبل لصق القيم .Cells.PasteSpecial Paste:=xlAll .Cells.PasteSpecial Paste:=xlPasteValues

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

أضف سطر الإعلان عن المتغيرات في أول الموديول Dim LR As Long, LRQ As Long, Cell As Range وإن شاء الله يتم حل المشكلة تقبل تحياتي

السلام عليكم اقول : جزيت خيرا - جزيت خيرا - جزيت خير اقول : رزقك الله حظ الدنيا والاخرة اقول : تمام تمام تمام 100 % انتهى البطأ اشكرك

أخي الكريم محمد اضغط من لوحة المفاتيح Alt + F11 هتدخل على محرر الأكواد من قائمة Insert هتلاقي الأمر Module انسخ الكود والصقه في الموديول احفظ الملف .. لما تظهر لك رسالة الحفظ بتكتب اسم الملف وتحدد مكانه وأهم شيء تخلي الامتداد Macro Enabled (نوع الحفظ من نفس النافذة) وأي استفسار ستجدنا بعون الله وتوفيقه تقبل تحياتي

أخي وحبيبي مختار بارك الله فيك ملف رائع وجميل ولكن لاحظ ان المخرجات مرتبطة بالملف الأصلي .. روح على الشيت التالت في أي مصنتف من المخرجات تقبل تحياتي

بارك الله فيك أخي وحبيبي في الله سعيد بيرم كود رائع بحق ..تسلم الأيادي إليك أخي الكريم رضا راغب الملف المرفق فيه تطبيق كود أخونا الحبيب سعيد بيرم يتم الترحيل حسب الكود المرفق في الملف كل 5 ثواني (للتجربة فقط ..يمكنك تغيير الوقت المطلوب من الكود) Transfer Data Every 5 Seconds.rar

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

أخي الكريم مصطفى محمود مصطفى إليك الملف المرفق الخاص بك .. والعمل بالأكواد بدون معادلات .. حيث أن معادلات الصفيف لا أحبذها كثيراً يوضع الكود التالي في موديول عادي Public Coll As New Collection Public Function RefreshCollection() As Collection Dim collDummy As New Collection, ArrIn, ArrHead, I As Long, J As Long, Str1 As String, V Set Coll = Nothing With Sheet1.Range("C46").CurrentRegion ArrIn = .Value ArrHead = .Resize(1).Offset(-44).Value For J = 3 To UBound(ArrIn, 2) Step 2 For I = 2 To UBound(ArrIn, 1) If Len(ArrIn(I, J)) Then On Error Resume Next Str1 = CStr(ArrIn(I, J)) V = Coll(Str1) If Err.Number <> 0 Then Set collDummy = Nothing Coll.Add Key:=Str1, Item:=collDummy End If On Error GoTo 0 Coll(Str1).Add Array(ArrIn(I, J), ArrIn(I, J - 1), ArrHead(1, J - 1)) End If Next I Next J End With Set RefreshCollection = Coll End Function Public Function GetData(Param As String) Dim ArrOut, I As Long, V1, V2 If Coll.Count = 0 Then Set Coll = RefreshCollection() On Error Resume Next Set V1 = Coll(Param) If Err.Number = 0 Then ReDim ArrOut(1 To V1.Count, 1 To 2) For Each V2 In V1 I = I + 1 ArrOut(I, 1) = V2(1) ArrOut(I, 2) = V2(2) Next V2 GetData = ArrOut End If On Error GoTo 0 End Function ويوضع الكود التالي في حدث ورقة العمل المسماة حصص المعلمين Private Sub Worksheet_Activate() Set Coll = RefreshCollection() End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim Arr Application.EnableEvents = False Select Case Target.Address(0, 0) Case "H4" Range("G6:H1000").ClearContents Arr = GetData(Target.Value) If IsArray(Arr) Then Range("G6").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr Case "K4" Range("J6:K1000").ClearContents Arr = GetData(Target.Value) If IsArray(Arr) Then Range("J6").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr End Select Application.EnableEvents = True End Sub غير رقم المعلم في الخلايا الصفراء وفقط تقبل تحياتي Grab Data By Teacher's ID YasserKhalil.rar

السلام عليكم من اخيك الاسيوطي ياخي مختار الاسيوطي التي افخر انها تضم عباقره مثلك اخي الحبيب عمل رائع يضم لقائمه اعمالك الرائعه .لي طلب اخير ان الصفحه الاولي صفحه sales لاتخرج مع باقي الملفات جزاك الله خيرا

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

السلام عليكم مشكور - يرحم والديك - ويرزقكم الجنة تمام مشكور

جرب هذا الملف talween.zip

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

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

أستاذى الفاضل ياسر السطر ده يستدعى صندوق Style ومنه نختار الفورمات خط ولون ومحاذاة وحماية ........... Application.Dialogs(xlDialogApplyStyle).Show أو السطر ده : Application.Dialogs(xlDialogDefineStyle).Show الأخ ابو احمد تجميع الاوامر بالشكل الذى تريده لا يمكن حتى الان لانه من أساسيات الاوفيس لكن بامكانك عمل زر لكل قائمة تحياتى

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

اخي الحبيب ابراهيم اؤيد راي اخي الحبيب ياسر شرحك سلس وسيكون مرجعا للكثيرين بارك لله فيك وبالتوفيق خالص تحياتي

لست خبيرا بالماكرو ولكن وجدت في هذه الصفحة https://social.msdn.microsoft.com/Forums/office/en-US/79855849-4809-4777-8a47-2dec56a1313c/macros-to-change-line-and-paragraph-spacing وحدتَي ماكرو قد تفيدانك. الأولى لزيادة التباعد بين الأسطر نصف نقطة والثانية لإنقاص التباعد نصف نقطة Sub IncreaseLineSpace() On Error Resume Next With Selection.ParagraphFormat .LineSpacing = .LineSpacing + 0.5 End With End Sub Sub DecreaseLineSpace() On Error Resume Next With Selection.ParagraphFormat .LineSpacing = .LineSpacing - 0.5 End With End Sub طبعا يمكنك صنع اختصار للوحدتين في شريط أدوات الوصول السريع والنقر على الزرين لزيادة / إنقاص التباعد نصف نقطة مع كل نقرة.

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

بارك الله فيك أخي الحبيب إبراهيم ابو ليلة شروحات في منتهى الروعة والإتقان

أسعد الله أوقاتكم بكل خير فيما يلي الدرس التاسع من دورة "إكسيل 2013 المستوى المتقدم" بعنوان دوال قواعد البيانات- الجزء الأول الدرس التاسع - دوال قواعد البيانات 1 أتمنى لكم مشاهدة ممتعة ومفيدة يمكنكم تحميل ملفات التمارين الخاصة بهذه الدورة من خلال الرابط التالي: http://www.4shared.com/rar/QvwJQLddce/_-__.html دمتم بخير أخوكم م/نضال الشامي Google+

الطريقه الٍسادسه :- تعبئه الكمبوبوكس باستخدام الحلقه التكراريه For Each (طريقه احترافيه) لو عندى شيت زى كدا وفيه بيانات وعايز اقوم بتعبئة الكمبوبوكس بالبيانات المظلله باللون الاخضر شاهد الصوره مثال :- مطلوب تعبئة الكمبوبوكس 1 بالبيانات المظلله باللون الاخضر هنعمل الكود التالى With ComboBox1 For Each Data In Sheet1.Range("A2:A" & Sheet1.Cells(Rows.Count, "a").End(xlUp).Row) .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value Next End With نشرح الكود ونمشى وحده وحده ونشوف ازى تم كتابته بالسطر الاول استخدمنا With ComboBox1 يعنى بنقول للكود الشغل بتاعنا هيكون مع الكمبوبوكس 1 ( الكمبوبوكس المطلوب تعبئته ) وطبعا طالما فتحنا With يبقى لازم نقفلها بــ End With زى كدا With ComboBox1 End With السطر التانى استخدمنا الحلقه التكرارية For Each وسميت الحلقه بأسم Data (وممكن تسميها اى اسم او احرف اخرى كما يحلو لك ) Data موجوده فى اى نطاق قلتله موجود فى النطاق من A2 الى اخر خلية بها بيانات فى العمود A ( وطبعا عرفنا ازاى قبل كدا نعرف اخر صف به بيانات فى اى شيت وفى اى عمود ) وكدا الحلقه التكرارية هتبدأ تلف على كل خليه فى النطاق المذكور بدأ من الخلية A2 وطبعا لازم نقفل الحلقه بـ Next For Each Data In Sheet1.Range("A2:A" & Sheet1.Cells(Rows.Count, "a").End(xlUp).Row) Next فلحلقه لما تبدأ هيكون Data = A2 Next الكود هيروح للخليه اللى بعدها Data = A3 Next الكود هيروح للخليه اللى بعدها Data = A4 Next الكود هيروح للخليه اللى بعدها وهكذا حتى يصل الى اخر خليه بها بيانات بالعمود وهى A11 كدا الحلقه بتلف بدون فائده او بالادق بدون مهمه تنفذها مجرد فقط انه بيلف انا عايز استفيد من الفه بتاعته دى فنعمل ايه هقوله وانت بتلف اعمل حاجتين خلى Data اللى هى فى اول لفه هتكون قيمتها A2 دخلها فى العمود الاول للكمبوبوكس ( ملحوظه العمود الاول فى الكمبوبوكس بيكون رقمه 0 والخليه المجاورة لها بالعمود B اللى هى B2 دخلها بالعمود الثانى بالكمبوبوكس ( ملحوظه العمود الثانى بيكون رقمه 1 ) وهكذا وهو بيمر على كل خليه بالنطاق هيعمل كدا .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value ترتيب الاعمده فى الكمبوبوكس بيدأ من 0 وكذالك ترتيب الصفوف بيدأ من 0 AddItem هى العمود رقم 0 فى الكمبوبوكس والعمود ده يساوى Data اللى هى كل خليه هتمر فيها الحلقه اللى هى اسماء العملاء بالعمود A والعمود رقم 1 فى الكمبوبوكس هو (List(.ListCount - 1, 1. هيظهر فيه كود العميل اللى بالعمود B (رقم العمود , صفوف الكمبوبوكس)List. صفوف الكمبوبوكس بتبدأ من 0 زى ما قلت علشان كدا قلت ان صفوف الكمبوبوكس - 1 **** ListCount - 1. طيب العمود رقم 1 عايزين نظهر فيه الكود اللى بالعمود B بالشيت فنعمل ايه Data.Offset(0, 1).Value= هنا استخدمنا الداله offset فى اول لفه للحلقه هيكون Data = A2 فأنا بقوله انتقل من A2 بمقدار صف 0 والعمود 1 ( يعنى ايه صف 0 يعنى نفس الصف والعمود واحد يعنى تحرك وروح للعمود B اخر شئ طبعا الكود ده وقت تنفيذه انت اللى بتحدده ولكن على سبيل المثال انا عايز اكتبه فى حدث تشغيل الفورم فيكون كالتالى Private Sub UserForm_Initialize() With ComboBox1 For Each Data In Sheet1.Range("A2:A" & Sheet1.Cells(Rows.Count, "a").End(xlUp).Row) .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value Next End With End Sub والى لقاء اخر من حلقات سلسلة علمنى كيف اصطاد وطريقه اخرى من طرق تعبئة الكمبوبوكس الطريقه القادمه هنعرف ازاى نجلب البيانات بالكمبوبوكس دون تكرار انتظرونا تقبلوا تحياتى

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

السلام عليكم إخواني الكرام إليكم الملف المرفق فيه نبذة عن المصفوفات .. أرجو من الله أن ينفع به المسلمين Arrays.rar

السلام عليكم ورحمة الله وبركاته الدرس الخامس 5-Colors الالوان وسوف نتناول فى هذه الدرس الاتى استخدام الخاصيه color استخدام الخاصيه ColorIndex استخدام الخاصيه Interior.Color استخدام الخاصيه borders.color استخدام الخاصيه Tab.Color ............................................................. استخدام الخاصيه color تستخدم الخاصيه COLOR فى تلوين الخطوط FONT يجب ان نشير الى اننا حينما نتعامل مع color فاننا نستخدم الخاصيه الخاصه بالالوان RGB سنجد ان قيمة RGB مكونه من ثلاث معطيات هى الاحمر -- الاخضر --الازرق .RGB(red_value, green_value, blue_value) وسوف نقدم بعض القيم والالوان الخاصه ب RGB الان نتعرف على كيفية استخدام هذه الخاصيه فى تلوين الخط نفترض اننا لدينا الاسم HIMA فى الخليه A17 ونريد تلوين الخط باللون الازرق سيكون شكل الكود كالاتى Sub colorfont() Range("a17").Font.Color = RGB(0, 0, 255) ' blue End Sub وطبعا لو عايز تغير اللون لاى لون انت عايزه كل الى عليك ان هتغير الارقام الخاصه بالخاصيه RGB استخدام الخاصيه ColorIndex تستخدم ايضا فى التعامل مع تلوين الخطوط ولكن يتم الاشاره هنا الى الالوان بالارقام العدديه من 1 الى 56 راجع الصوره فمثلا لو لدينا الاسم HIMA فى الخليه A21 ونريد تلوينه باللون الاحمر سيكون شكل الكود كالاتى Sub ColorIndexfont() Range("A25").Font.ColorIndex = 3 'red End Sub استخدام الخاصيه borders.color تستخدم هذه الخاصيه فى تلوين حدود الخلايا وطبعا احنا عرفنا قبل كده ازاى نتعامل مع COLOR عن طريق RGB نفترض اننا عايزن نحدد الحليه B33:D33 باللون الازرق سيكون شكل الكود كالاتى Sub coloredborders() Range("b33:d33").Borders.Color = RGB(0, 0, 255) ' blue End Sub استخدام الخاصيه Interior.Color تستخدم هذه الخاصيه فى تلوين الخلايا وطبعا احنا عرفنا قبل كده ازاى نتعامل مع COLOR عن طريق RGB نفترض اننا عايزين نلون الخلايا من B41:D41 باللون الاخضر سيكون شكل الكود كالاتى Sub backgroundcolor() Range("b41:d41").Interior.Color = RGB(0, 255, 0) ' green End Sub استخدام الخاصيه Tab.Color تستخدم هذه الخاصيه فى التعامل مع تبويب الشيتات Sub colorwsheettab() Sheets("5-Colors").Tab.Color = RGB(0, 0, 255) ' blue End Sub فلو احنا عايزين نلون تبويب الشيت المسمى ب 5-Colors باللون الازرق مثلا هيكون شكل الكود كالاتى Sub colorwsheettab() Sheets("5-Colors").Tab.Color = RGB(0, 0, 255) ' blue End Sub اتمنى ان يكون الدرس مفيدا مرفق شيت اكسيل به التطبيقات learnvba.rar تقبلوا تحياتى learnvba.rar

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

&&&&اخر تعديل لبرنامج المرتبات للسنة المالية الجديدة : 2014/2015 م اهداء الى اخى احمد المعز اعاده الله الينا سالما منتصرا بعد عرض البرنامج على الاخوة الزملاء ذوى الخبرة والذين يفوقوا علمنا ومعرفتنا البسيطة والاخذ بتوجهاتهم فقمت بالتعديل وهذا اخر تعديل بتاريخ 9/7/2014 ورقم الحماية هو رقم محمولى الموجود على صفحة البرنامج لمن يريد الاضافة او التعديل ودعواتكم لاخى احمد المعز قريبا سيكون بيننا لنزداد من علمه وافكاره وابتكاراته والله لنحترق شوقا اليك والى حديثك وحكمة عقلك هذا الرابط للتحميل http://www.officena.net/ib/index.php?app=downloads&showfile=161

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