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

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

حديث لرسول الله -صلى الله عليه وسلم-، يقول: عن أبي هريرة -رضي الله عنه- أن رسول الله -صلى الله عليه وسلم- قال: إذا مات ابن آدم انقطع عمله إلا من ثلاث: صدقة جارية، أو علم ينتفع به، أو ولد صالح يدعو له، رواه مسلم راحل عنا امس العلامه القدير الاستاذ عماد الدين الحسامى وترك لنا علم ينتفع به حبيب اذكركم ببعض ما ترك لنا من اعمال وعلم ينتفع به أسال الله تعالى ان تكون جميع اعماله فى ميزان حسناته ممكن حضرتك تدخل على مكتبه الاستاذ عماد ونشوف اعماله من صفحته الشخصيه بالمنتدى الحسامى.zip الحسامى 2.zip شرح الفورم.zip نظام الحسامي للمخازن.zip واجهه كنترول للاستاذ الحسامي.zip شجرة الحسابات-عماد الحسامي.zip

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

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

لم ألتفت الى المعادلات أشكرك أخى ياسر على دقة المتابعة تم تعديل نوع لصق المنسوخ فى الكود Option Explicit Sub SaveShtsAsBook() Dim MyFilePath As String, SheetName1 As String, SheetName2 As String, sh As Worksheet, NB As Workbook MyFilePath = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & Format([a1], "dd-mm-yyyy") With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next MkDir MyFilePath For Each sh In Sheets(Array("cairo 1", "cairo2", "u2", "Alex ", "Delta 3", "Delta 2", "Delta 1", "u1")) sh.Activate SheetName1 = ActiveSheet.Name SheetName2 = ActiveSheet.Name & "" & [c1] Cells.Copy Set NB = Workbooks.Add(xlWBATWorksheet) With NB With .ActiveSheet .Cells.PasteSpecial Paste:=xlPasteValues .Name = SheetName1 [a1].Activate End With ThisWorkbook.Sheets("Stk").Copy Before:=NB.Sheets(1) .SaveAs Filename:=MyFilePath & "\" & SheetName2 & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False .Close SaveChanges:=True End With .CutCopyMode = False Set NB = Nothing Next sh Sheets("SAles").Activate .ScreenUpdating = True .DisplayAlerts = True End With End Sub

لا استطيع الا ان اقول لله درك وزادك من علمة مميز كعادتك. تم حل المشكلة.

بارك الله فيك اخى الكريم (ياسر خليل أبو البراء ) وجعله فى ميزان حسناتك

ههههههههههههههههى لو كنت أفضل واحدة لطبقتها كلها فيها ثغرات للدخول الى الملف

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

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

وعليكم السلام أستاذ وائل استبدل السطر التالى فى كود المرفق ThisWorkbook.Sheets(Array("SAles", "Stk")).Copy Before:=NB.Sheets(1) بالسطر التالى : ThisWorkbook.Sheets("Stk").Copy Before:=NB.Sheets(1) تحياتى

أخي الكريم مصطفى محمود مصطفى إليك الملف المرفق الخاص بك .. والعمل بالأكواد بدون معادلات .. حيث أن معادلات الصفيف لا أحبذها كثيراً يوضع الكود التالي في موديول عادي 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

أخي الكريم جرب الملف المرفق التالي ** الكود مقسم إلى كود يوضع في موديول عادي Public Arr, ArrOut Sub RefreshArray() Dim WS As Worksheet, ArrTemp, I As Long, P As Long ReDim Arr(1, 0) For Each WS In Sheets If WS.Name <> "البحث" And WS.Name <> "تصفية البيانات المكررة " And WS.Name <> "بيانات ثانوية" Then If WS.Cells(Rows.Count, "G").End(xlUp).Row > 1 Then ArrTemp = WS.Range("A1").CurrentRegion.Columns("G").Value I = UBound(Arr, 2) + UBound(ArrTemp, 1) ReDim Preserve Arr(1, I) For I = 2 To UBound(ArrTemp, 1) If Len(ArrTemp(I, 1)) Then Arr(0, P) = ArrTemp(I, 1) Arr(1, P) = WS.Name & "/" & I P = P + 1 End If Next I End If End If Next WS ReDim Preserve Arr(1, P - 1) End Sub Sub GetSearchResult(Param As String) Dim LastRow As Long, I As Long, P As Long If Not IsArray(Arr) Then RefreshArray ReDim ArrOut(1, UBound(Arr, 2)) With Sheets("البحث") LastRow = Application.Max(.Cells(.Rows.Count, "E").End(xlUp).Row, 3) .Range("E3:E" & LastRow).ClearContents P = 0 For I = LBound(Arr, 2) To UBound(Arr, 2) If InStr(1, Arr(0, I), Param, vbTextCompare) Then ArrOut(0, P) = Arr(0, I) ArrOut(1, P) = Arr(1, I) P = P + 1 End If Next I If P > 0 And Param <> "" Then ReDim Preserve ArrOut(1, P - 1) .Range("E3").Resize(UBound(ArrOut, 2) + 1, 1).Value = Application.Transpose(ArrOut) Else .Range("B2:B26,D2:D26").ClearContents End If End With End Sub Sub RefreshList(Param As Long) Dim Arr, ArrOut1(1 To 25, 1 To 1), ArrOut2(1 To 25, 1 To 1), I As Long With Sheets("البحث") .Range("B2:B26,D2:D26").ClearContents On Error Resume Next Arr = Sheets(Split(ArrOut(1, Param - 3), "/")(0)).Rows(Val(Split(ArrOut(1, Param - 3), "/")(1))).Resize(, 56).Value If Err.Number <> 0 Then Exit Sub On Error GoTo 0 ArrOut1(1, 1) = Arr(1, 9) For I = 2 To 25 ArrOut1(I, 1) = Arr(1, I + 5) Next I For I = 1 To 25 ArrOut2(I, 1) = Arr(1, I + 31) Next I .Range("B2").Resize(UBound(ArrOut1, 1), UBound(ArrOut1, 2)).Value = ArrOut1 .Range("D2").Resize(UBound(ArrOut2, 1), UBound(ArrOut2, 2)).Value = ArrOut2 End With End Sub والجزء الثاني يوضع في حدث ورقة العمل المسماة "البحث" Private Sub TextBox1_Change() GetSearchResult TextBox1.Text End Sub Private Sub Worksheet_Activate() RefreshArray End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Columns("E")) Is Nothing Then If Target.Row >= 3 And Target.Count = 1 Then If Len(Target.Value) Then RefreshList Target.Row End If End If End Sub أرجو أن يكون المطلوب ويعالج مشكلة البطء لديك إن شاء الله تقبل تحياتي Textbox Search All Sheets YasserKhalil.rar

حدد فقط الصف الذي تريد اكسل يخفي لك كل شيء و لا ترى الا ما تريد بكبسة زر show_in top.zip

اول مشاركة لية ارجو ان تكون مفيدة ملف بفورم يعرض اسماء الله الحسنى بالصورة والشرح مع شاشة اافتتاحية لمدة زمنية الشيتات محمية بالرقم 123 الكود غير محمي اي استفسار مرحب بها الرابط http://www.mediafire.com/download/c2ypmw5hrw8ru7f/Names.rar Names.rar

اشكرك اخي ولك بالمثل أطلع على المرفق تحياتي وزارات المحافظة_ توسع الجدول_2.rar

جرب الكود في موديول عادي واربطه بزر أمر سيعمل معك إن شاء الله Sub FilterSpecific() Application.ScreenUpdating = False With Sheets("Quires").Range("B15:G1000") .Offset(1).ClearContents .Borders.LineStyle = xlNone End With With Sheets("SQ") .Rows(1).AutoFilter .Rows(1).AutoFilter 11, "=" & Sheets("Quires").Range("H9") LR = .Range("A" & .Rows.Count).End(xlUp).Row If LR > 1 Then Union(.Range("D2:E" & LR), .Range("G2:G" & LR), .Range("J2:J" & LR), .Range("L2:L" & LR)).Copy Sheets("Quires").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues End If .Rows(1).AutoFilter End With With Sheets("Quires") LRQ = .Range("C" & .Rows.Count).End(xlUp).Row If LRQ > 15 Then For Each Cell In .Range("B16:B" & LRQ) Cell = Cell.Row - 15 Next Cell End If With .Range("B15").CurrentRegion .Borders.Weight = xlThin .BorderAround Weight:=xlThick End With .Range("H9").Select End With Application.ScreenUpdating = True End Sub لا أدر ما السبب في عدم عمل الكود في حدث الورقة لديك .. قد تكون هناك مشكلة في مكان ما أو لربما لأن خلية الشرط مدمجة ...كل الاحتمالات واردة

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

أخي الكريم سعد يرجى تغيير اسم الظهور بشكل مناسب ليظهر اللقب مع الاسم إليك الكود التالي يوضع في حدث ورقة العمل المسماة Quires ..بمجرد الاختيار من الخلية H9 Private Sub Worksheet_Change(ByVal Target As Range) Dim LR As Long, LRQ As Long, Cell As Range If Target.Cells.CountLarge > 1 Then Exit Sub If Not Intersect(Target, Range("H9")) Is Nothing Then Application.ScreenUpdating = False With Sheets("Quires").Range("B15:G1000") .Offset(1).ClearContents .Borders.LineStyle = xlNone End With With Sheet1 .Rows(1).AutoFilter .Rows(1).AutoFilter 10, "=" & Sheets("Quires").Range("H9") LR = .Range("A" & .Rows.Count).End(xlUp).Row If LR > 1 Then Union(.Range("D2:F" & LR), .Range("I2:I" & LR), .Range("K2:K" & LR)).Copy Sheets("Quires").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues End If .Rows(1).AutoFilter End With With Sheets("Quires") LRQ = .Range("C" & .Rows.Count).End(xlUp).Row If LRQ > 15 Then For Each Cell In .Range("B16:B" & LRQ) Cell = Cell.Row - 15 Next Cell End If With .Range("B15").CurrentRegion .Borders.Weight = xlThin .BorderAround Weight:=xlThick End With .Range("H9").Select End With Application.ScreenUpdating = True End If End Sub وإليك الملف المرفق تقبل تحياتي Filter Copy Specific Data YasserKhalil.rar

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

بعد اذن الاساتذه الكرام هذا حل اخر بمعادلة =IF((ROW(F9)-ROW($F$8))<=$G$8;$F$8;"") تكرار بناء على عدد.rar

أخي الكريم رضا جرب الكود التالي عله يفي بالغرض Sub TarhilRanges() Dim R As Range For Each R In Sheet1.Columns("A").SpecialCells(2, 1).Areas Application.Wait (Now + TimeValue("00:00:05")) R.CurrentRegion.Copy Sheets("Sheet2").Cells(R.Row, "C") Next R Application.CutCopyMode = False MsgBox "Done!", 64 End Sub

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

جميل جداً أخي الحبيب سليم والأجمل الإعلان عن المتغيرات .. بالنسبة للمتغير Integer قرأت في أكثر من مصدر أنه من الأفضل الإعلان عنه من النوع Long (إذ أنه حتى لو تم الإعلان عنه من النوع Integer فإن الفيجوال بيسك يقوم بتحويله إلى Long) هذا والله أعلى وأعلم

اخي ياسر اثراء للموضوغ اليك هذا الكود تستطيع ان تحدد اكثر من صف و اكثر من عامود للنكرار Sub repet() Dim myrg As Range Dim t As Integer Set myrg = Application.InputBox("Enter your data", Type:=8) t = Application.InputBox("Enter your number", Type:=1) myrg.Copy ActiveCell.Resize(t * myrg.Rows.Count, myrg.Columns.Count) End Sub

الاخ الفاضل جرب التالى من قائمة data اختر edit link وتأكد من أن الخيار automatic نشط ومن الصندوق الحوارى اضغط startup prompt من الصندوق الجديد حدد الخيار 3 ثم ok ثم close احفظ الملف واقفله ثم أعد الفتح وشوف

الطريقه الٍسابعه :- تعبئه الكمبوبوكس بدون تكرار باستخدام الحلقه التكراريه For Each و الداله Countif (طريقه احترافيه) لو عندى شيت زى كدا وفيه بيانات وعايز اقوم بتعبئة الكمبوبوكس بالبيانات المظلله باللون الاخضر ولكن دون تكرارشاهد الصوره هنستخدم نفس الكود السابق ولكن مع اضافه الداله Countif الكود هيكون كالتالى With ComboBox1 For Each Data In Sheet1.Range("A2:A" & Sheet1.Cells(Rows.Count, "a").End(xlUp).Row) i = Data.Row aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) If aa = 1 Then .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value End If Next End With أنا هحاول بقدر الامكان اعيشك فيديو تشوف الكود اثناء التنفيذ بيعمل ايه السطرالاول هو With ComboBox1 يعنى بنقول للكود الشغل بتاعنا هيكون مع الكمبوبوكس 1 ( الكمبوبوكس المطلوب تعبئته ) السطر الثانى هو الحلقة التكرارية For Each وقمنا بتسميتها اسم افتراضى وليكن Data ( وممكن تسميها اى اسم او حرف او مجموعه من الحروف ) طيب Data وين موجوده فى اى نطاق قلتله فى In Sheet1.Range("A2:A" & Sheet1.Cells(Rows.Count, "a").End(xlUp).Row يعنى النطاق من A2 الى اخر خلية بها بيانات فى العمود A اللى هى بالصوره السابقه A7 ( طبعا عرفنا ازاى نكتب سطر البحث عن اخر خليه بها بيانات) كدا عرفنا النطاق وهيكون من A2 :A7 طبقا للصوره موضوع الشرح ( وطبعا عند زياده المدى وليكن كتابة اسم جديد فى الخلية A8 سوف يقوم الكود بمعرفه النطاق من A2:A8 ) الحلقه دلوقتى عرفت النطاق بتاعها وهتبدأ تلف على خلية خلية فى هذا النطاق وكل مره هيكون الحلقه Data لها اسم خليه معينه فى المره الاولى سيكون قيمة Data هى A2 والكود هينتقل الى السطر التالى وهو i = Data.Row عملت متغير اسمه i وقلت أن i تساوى Data.Row يعنى رقم الصف اللى فيه Data دلوقتى Data هى A2 والخلية A2 كم رقم الصف بتاعها هو الصف رقم 2 أذن i = 2 الكود هيروح للسطر اللى بعد كدا وهو aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) هنا عملت متغير وسميتها aa وقلت ان aa تساوى قيمة معادله ما هى المعادله هى Countif وهى تعنى عمل احصاء على شئ ما داخل نطاق محدد عند الاعلان عن معادله فى اى كود لازم نكتب الجمله دى .Application.WorksheetFunction ثم اسم الداله اللى انت عايزها انا دلوقتى محتاج الداله Countif وهى ( CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data نطاق العمل هو المظلل باللون الاحمر وشرط الاحصاء هو اللون الاخضر جزء النطاق هو ( الى , من )Sheet1.Range السؤال هنا من ايه ؟ الى ايه؟ من A2 بس فى الكود مش هكتبها A2 هستخدم Cells و Cells عباره عن (رقم العمود, رقم الصف)Cells ِA2 كم رقم الصف بتاعها رقم 2 وكم رقم العمود بتاعها رقمه 1 اذن A2 تساوى (Cells(2, 1 الى ايه ؟ الى اى خلية ؟ الى هنا هتكون متغيره انا بالمره الاولى عايزه الى A2 والمره التانيه الى A3 والمره الثالثه الى A4 وهكذا طيب ودى بقى اكتبها ازاى ؟ ركز معايا يا عبدالتواب شايفك نمت منى فى Cells مش احنا قلنا ان Cells عباره عن (رقم العمود, رقم الصف)Cells طيب رقم الصف كل مره هو اللى مش معروف لكن رقم العمود هو اللى معروف طيب اعرف ازاى رقم الصف علشان كدا انا عرفت المتغير i فى السطر الثالث بالكود i = Data.Row فنكتب الى كدا (Cells(i, 1 الصف متغير من خلال i والعمود ثابت وهو عمود A ورقمه 1 اذن النطاق فى اول لفه للكود هيكون من A2:A2 وشرط الاحصاء هو Data اللى هى قيمة الخلية A2 ( عبدالله باقشير) فالمعادله aa هيكون كم 1 طبعا ليه لان عبدالله باقشير فى النطاق من A2:A2 مظهرش غير مره وحده فقط بعد كدا الكود هينتقل الى السطر التالى وهو If aa = 1 Then استخدمت If لاختبار قيمة aa هل هى تساوى 1 أو لا اذا كانت 1 نفذ السطر اللى بعده واذا مش تساوى 1 اقفل if وانتقل الى Next طبعا فى اللفه الاولى اللى احنا فيها دلوقتى aa = 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 كدا فى اول لفه للحلقه دخل اسم عبدالله باقشير فى العمود الاول للكمبوبوكس ودخل كود العميل وهو 101 فى العمود الثانى للكمبوبوكس هيقفل If ثم ينتقل الى السطر التالى وهو Next Next تعنى ارجع للحلقه For Each مره اخرى فلما يرجع هيكون Data تساوى قيمة A3 ثم ينتقل الى السطر التالى وهو i = Data.Row دلوقتى Data هى A3 والخلية A3 كم رقم الصف بتاعها هو الصف رقم 3 أذن i = 3 هينتقل الى السطر اللى بعده وهو سطر المعادله aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) (Cells(2, 1 اللى هى A2 و (Cells(i, 1 المتغير i دلوقتى رقمه 3 اذن (Cells(3, 1 وهى تعنى الخلية A3 يعنى نطاق هو من A2:A3 وشرط الاحصاء هو Data وقيمتها الحاليه فى هذه الفه A3 (ياسر خليل ) كم مره ظهر اسم ياسر خليل فى النطاق من A2:A3 ظهر مره وحده اذن المتغير aa = 1 الكود هينتقل الى السطر التالى If aa = 1 Then طبعا الشرط محقق لان aa = 1 فهينفذ السطريين التاليين .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value يعنى هيدخل ياسر خليل فى العمود الاول للكمبوبوكس وهيدخل الكود بتاعه 102 فى العمود الثانى للكمبوبوكس هيقفل If ثم ينتقل الى السطر التالى وهو Next Next تعنى ارجع للحلقه For Each مره اخرى فلما يرجع هيكون Data تساوى قيمة A4 ثم ينتقل الى السطر التالى وهو i = Data.Row دلوقتى Data هى A4 والخلية A4 كم رقم الصف بتاعها هو الصف رقم 4 أذن i = 4 هينتقل الى السطر اللى بعده وهو سطر المعادله aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) (Cells(2, 1 اللى هى A2 و (Cells(i, 1 المتغير i دلوقتى رقمه 4 اذن (Cells(4, 1 وهى تعنى الخلية A4 يعنى نطاق هو من A2:A4 وشرط الاحصاء هو Data وقيمتها الحاليه فى هذه الفه A4 (عبدالله باقشير ) كم مره ظهر اسم عبدالله باقشير فى النطاق من A2:A4 ظهر مرتين اذن المتغير aa = 2 الكود هينتقل الى السطر التالى If aa = 1 Then طبعا الشرط لم يتحقق لان aa = 2 فمش هينفذ السطريين التاليين لان انا مش عايز الاسم يكرر فى الكمبوبوكس يظهر فقط مره وحده .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value هيقفل If ثم ينتقل الى السطر التالى وهو Next Next تعنى ارجع للحلقه For Each مره اخرى فلما يرجع هيكون Data تساوى قيمة A5 ثم ينتقل الى السطر التالى وهو i = Data.Row دلوقتى Data هى A5 والخلية A5 كم رقم الصف بتاعها هو الصف رقم 5 أذن i = 5 هينتقل الى السطر اللى بعده وهو سطر المعادله aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) (Cells(2, 1 اللى هى A2 و (Cells(i, 1 المتغير i دلوقتى رقمه 5 اذن (Cells(5, 1 وهى تعنى الخلية A5 يعنى نطاق هو من A2:A5 وشرط الاحصاء هو Data وقيمتها الحاليه فى هذه الفه A5 (محمد حسن المحمد) كم مره ظهر اسم محمد حسن المحمد فى النطاق من A2:A5 ظهر مره وحده اذن المتغير aa = 1 الكود هينتقل الى السطر التالى If aa = 1 Then طبعا الشرط محقق لان aa = 1 فهينفذ السطريين التاليين .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value يعنى هيدخل محمد حسن المحمد فى العمود الاول للكمبوبوكس وهيدخل الكود بتاعه 103 فى العمود الثانى للكمبوبوكس هيقفل If ثم ينتقل الى السطر التالى وهو Next Next تعنى ارجع للحلقه For Each مره اخرى فلما يرجع هيكون Data تساوى قيمة A6 ثم ينتقل الى السطر التالى وهو i = Data.Row دلوقتى Data هى A6 والخلية A6 كم رقم الصف بتاعها هو الصف رقم 6 أذن i = 6 هينتقل الى السطر اللى بعده وهو سطر المعادله aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) (Cells(2, 1 اللى هى A2 و (Cells(i, 1 المتغير i دلوقتى رقمه 5 اذن (Cells(6, 1 وهى تعنى الخلية A6 يعنى نطاق هو من A2:A6 وشرط الاحصاء هو Data وقيمتها الحاليه فى هذه الفه A6 (عبدالعزيز البسكرى) كم مره ظهر اسم عبدالعزيز البسكرى فى النطاق من A2:A6 ظهر مره وحده اذن المتغير aa = 1 الكود هينتقل الى السطر التالى If aa = 1 Then طبعا الشرط محقق لان aa = 1 فهينفذ السطريين التاليين .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value يعنى هيدخل عبدالعزيز البسكرى العمود الاول للكمبوبوكس وهيدخل الكود بتاعه 104 فى العمود الثانى للكمبوبوكس هيقفل If ثم ينتقل الى السطر التالى وهو Next Next تعنى ارجع للحلقه For Each مره اخرى فلما يرجع هيكون Data تساوى قيمة A7 ثم ينتقل الى السطر التالى وهو i = Data.Row دلوقتى Data هى A7 والخلية A7 كم رقم الصف بتاعها هو الصف رقم 7 أذن i = 7 هينتقل الى السطر اللى بعده وهو سطر المعادله aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) (Cells(2, 1 اللى هى A2 و (Cells(i, 1 المتغير i دلوقتى رقمه 7 اذن (Cells(7, 1 وهى تعنى الخلية A7 يعنى نطاق هو من A2:A7 وشرط الاحصاء هو Data وقيمتها الحاليه فى هذه الفه A7 (ياسر خليل) كم مره ظهر اسم ياسر خليل فى النطاق من A2:A7 ظهر مرتين اذن المتغير aa = 2 الكود هينتقل الى السطر التالى If aa = 1 Then طبعا الشرط لم يتحقق لان aa = 2 فمش هينفذ السطريين التاليين لان انا مش عايز الاسم يكرر فى الكمبوبوكس يظهر فقط مره وحده .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value هيقفل If ثم ينتقل الى السطر التالى وهو Next Next طبعا مش هيرجع فى هذه المره الى الحلقه لان النطاق انتهى وهينتقل الى End With كدا الكود انتهى وانا بصراحه انتهيت معاه من كتر اللف طبعا الكود بينفذ الكلام ده فى لمح البصر دون ان تشعر ولكن لو مساحه النطاق كبير مثلا من A2:A1000 سوف تبدأ تشعر ببطئ الكود ممكن مثلا ياخد 30ثانيه اخر شئ طبعا الكود ده وقت تنفيذه انت اللى بتحدده ولكن على سبيل المثال انا عايز اكتبه فى حدث تشغيل الفورم فيكون كالتالى Private Sub UserForm_Initialize() With ComboBox1 For Each Data In Sheet1.Range("A2:A" & Sheet1.Cells(Rows.Count, "a").End(xlUp).Row) i = Data.Row aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) If aa = 1 Then .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value End If Next End With End Sub وعند تشغيل الفورم ستجد الصوره التاليه لاحظ فى الصوره ان الكمبوبوكس يعرض فقط الاسماء دون تكرار ********************************************************************************************* والى لقاء اخر من حلقات سلسلة علمنى كيف اصطاد وطريقه اخرى من طرق تعبئة الكمبوبوكس الطريقه القادمه هنعرف ازاى نجلب البيانات بالكمبوبوكس دون تكرار بطريقه اخرى انتظرونا تقبلوا تحياتى

الطريقه الٍسادسه :- تعبئه الكمبوبوكس باستخدام الحلقه التكراريه 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

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

السلام عليكم ورحمة الله وبركاته الدرس الخامس 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

أحبتي في الله، وأخي الكريم صاحب الفكرة الرائعة السلام عليكم ورحمة الله لمعالجة مشكلة الاختيار بسهولة من القائمة المنسدلة بكتابة بدايات الحروف، أقوم عادة باستخدام ComboBox (ActiveX control) وأحدد مصدرها مدي معين أي استفسارات تحت أمركم إخوتي

السلام عليكم ورحمة الله وبركاته أخي الكريم ..الأعضاء في المنتدى لا يبخلون على أحد ، ولا ينتظرون مقابلاً مادياً ، ولا يتقاضون أجراً .. إنما كل يجود بما عنده ، من علم أو وقت .. فلا تستعجل .. وأكرر فلا تستعجل .. ولا تعتقد أنك بقولك " وينكم يا مبرمجين ؟ " أنك ستستنفرهم ، بالعكس ، لقد هممت ألا أجيب على طلبك ... ولكن خشيت أن أكون ممن يكتمون العلم فبالله عليكم إخواني رفقاً بإخوانكم .. رفقاً بإخوانكم الذي يقدمون المساعدة .. تفضل الملف المرفق .. فيه زري أمر أحدهما لبدء عملية الترحيل ، ويبدأ بعدها الترحيل كل 10 ثواني - بالطبع يمكنك تغيير الوقت كما تشاء - ، والزر الآخر لإيقاف عملية الترحيل .. أي إيقاف العداد .. أرجو أن يكون هذا هو المطلوب Transfer Data Every 10 Seconds.rar

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

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

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

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