مختار حسين محمود

جرب كده الملف ده من غير ما تدخل معادلات  بنفسك

5 تاريخ الميلاد والسن والنوع.rar

العفو أخى الكريم عبدالعزيز  نحن أخوة و بنتعلم من بعض جزاك الله خيرًا

السلام عليكم اخوتى

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

http://www.officena.net/ib/topic/55015-%D8%A7%D8%AC%D8%B9%D9%84-%D8%A7%D9%84%D8%A7%D9%83%D8%B3%D9%84-%D8%A7%D9%84%D9%85%D8%AA%D8%AD%D8%AF%D8%AB-%D8%A7%D9%84%D8%B1%D8%B3%D9%85%D9%89-%D8%A8%D8%A7%D8%B3%D9%85%D9%83/

أخى ياسر 

بنهرج معاك  لا يضيق صدرك بما قلت .  أنا - وأخوك زيزو أكيد - بنحبك فى الله 

يا ياسر فكرتنى بحكاية لطيفة

جماعة قالوا لواحد : تقدر تشيل الخروف ده  ؟

قال لهم : آآآآآآآه  هاتو الخروف ده  هو فين  ؟     هو فين و أنا أشيل أمه ؟

قام الجماعة جابو الخروف للراجل  وقالوا  الخروف اهه  تفضل اهه

الراجل ميل كتفه عشان يشيل الخروف مقدرش   فقالوا له :  هــــــــــــــا !    قال : معلش أنا مولف على شيل الجمال !
 

و الله أنت يا ياسر ابن حلال  ضحكتنى بجد  تحياتى لك و لعبدالعزيز

قبل  ما أرفق ملف 

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

اذا كان بعد التحويل فأنا بقولك  بلالالالالالالالالالالالالالالالاش الطيب أحسن 

يا أبو العربى يبقى ايه ؟؟؟؟   ان شاء الله صدقة  مش  كمان ننا  

استفسار : هو الملف التنفيذى قابل للكسر ؟  ما جربتش قبل كده !

هدية جميلة أخى سعد

جزاك الله بها خيرا

تقبل تحياتى

7 ساعات مضت, عبد العزيز البسكري said:

السّلام عليكم و رحمة الله و بركاته

أضحكتني .. أضحك الله سِنّك .. اِعتبرها صدَقة لهذا اليوم

جرّبت و جرّبت .. حاولت عديد المرّات لغاية الجمعة .. يوم العطلة .. فقلت خلاصْ .. لا بدّ من الاستعانة بأحد المكسِّرين الأقوياء

بارك الله فيك  .. جزاك الله خيرًا أستاذي الفاضل " مختار حسين محمود " و زادك من علمه و فضله

فائق إحتراماتي سيّدي الكريم

 

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

  حسب ما فهمت  تريد أن يختار  المستخدم    القيمة من الخلية B1 

 يمكن للمستخدم  أن يختار  القيمة من الخلية B1  أو أى خلية أخرى بها نسبة مئوية  حسب الكود التالى :

Sub yellow_cell3()
 Dim LR As Long, X As Integer, S
 LR = Cells(Rows.Count, 1).End(3).Row
 
 With Range("B2:B" & LR)
    .ClearContents
    .Interior.Pattern = xlNone
 End With
 
 Range("B4").Interior.ColorIndex = 6   ' حدد الخلية المراد تخطيها هنا
 Set S = Application.InputBox("حدد الخلية التى تريد الحساب على أساسها :", Title:="حساب النسبة المئوية", Type:=8)
 Application.ScreenUpdating = False
 Range("XFD1") = S
 For X = 2 To LR
     If Cells(X, 2).Interior.ColorIndex <> 6 Then
        Cells(X, 2).Formula = "=ROUNDDOWN((RC[-1]*INDIRECT(""XFD1"")),2)"
     End If
 Next
 Range("B2:B" & LR).Value = Range("B2:B" & LR).Value
 Application.ScreenUpdating = True
End Sub

 بالطبع  لا   و انتظر رأى الزملاء  قد يكون لدى أحدهم طريقة أخرى

جمعة مباركة بدأناها بعملية كسر             للتعلم  ليس أكثر

تفضل

برنامج الاختبارات مفتوح.rar

معلش للأخوة  اللى لسه معرفوش يجربوا  وللأخوة اللى مكسلين يجربوا

تحديد الخلايا التى تحتوى على حرف محدد.rar

أخى سليم حل رائع

بعد اذنك فى التعديل البسيط

(  تعريف المتعير LR و X و تمييز الخلية المستثناه من داخل الكود ليصبخ الكود مرناً ويمكن جعله أكثر مرونة بجعل المستخدم يختار الخلية وهو ما لم أذكره)

Sub yellow_cell2()
 Dim LR As Long, X As Integer
 LR = Cells(Rows.Count, 1).End(3).Row
 
 With Range("B2:B" & LR)
    .ClearContents
    .Interior.Pattern = xlNone
 End With
 
 Range("B4").Interior.ColorIndex = 6   ' حدد الخلية المراد تخطيها هنا
 For X = 2 To LR
     If Cells(X, 2).Interior.ColorIndex <> 6 Then
        Cells(X, 2).Formula = "=ROUNDDOWN((RC[-1]*15%),2)"
     End If
 Next
 Range("B2:B" & LR).Value = Range("B2:B" & LR).Value
End Sub

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

أخى عبدالعزيز 

اجابة على سؤالك : نعم يمكن ازالة كلمة المرور بمحرر الأكواد

فقط ارفع الملف للعمل عليه 

أخى الكريم سعد

بارك الله فيك لك كل التحية والتقدير لشخصكم الكريم

أخى الكريم  العزيز عبدالعزيز

أشكرك جزيل الشكر على كلماتك المشجعة ودعائك الطيب لك كل التحية والتقدير لشخصكم الكريم

أخى الكريم  الغالى المهندس الكبير ياسر فتحى

  أشكرك على كلماتك المشجعة ودعائك الطيب لك كل التحية والتقدير لشخصكم الكريم

أخى الكريم  العيدروس

أشكرك على اعجابك بالموضوع  لك كل التحية والتقدير لشخصكم الكريم

مشكور أخى طارق على البرنامج  جارى دراسته  جزاك الله خيرا

السلام عليكم ورحمة الله وبركاته

اليوم أعرض علي حضراتكم كودى الجديد  هذا الكود يساعدك على تحديد الخلايا التى تحتوى على حرف محدد 

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

الكود وعليه الشرح :

Option Explicit

Sub SCCSCharacter()
' الكود التالى لتحديد الخلايا التى تحتوى حرف
' By Mokhtar 3/12/2015
' المتغيرات
 Dim SelectRange, MyRng As Range, C As Range, MyString As String
' فى حالة حدوث خطأ تجاهله وانتقل للأمر التالى
 On Error Resume Next
 ' نطاق البحث
 Set MyRng = Sheet1.Range("C2", Range("C" & Rows.Count).End(xlUp))
 ' النص الذى أبحث عنه
 MyString = Sheets("Sheet1").Range("C1").Text
 'الغاء تحديث الشاشة
  Application.ScreenUpdating = False
 'ازالة التنسيق عن نطاق البحث
  MyRng.Interior.Pattern = xlNone
 ' حلقة تكرارية على كل خلايا نطاق البحث
 For Each C In MyRng '
     ' فحص اذا ما كانت الخلايا تحتوى النص الذى نبحث عنه أم لا
     If InStr(1, C.Value, MyString, vbTextCompare) > 0 Then '
        If SelectRange Is Nothing Then ' شرط اذا لم يكن المتغير موجوداً
           Set SelectRange = C  ' جواب الشرط : اعتبر أن المتغير يساوى قيمة الخلية
        Else 'اذا لم يتحقق الشرط
           Set SelectRange = Union(SelectRange, C) ' جواب الشرط : اعتبر أن المتغير يساوى اتحاد المتغير مع الخلية
        End If 'انهاء الشرط الاول
     End If ' انهاء الشرط الثانى
 Next ' الانتقال الى الخلية التالية
 
 If SelectRange Is Nothing Then   ' اذا لم يكن المتغير موجودا
    MsgBox "الحرف :" & " " & "( " & MyString & " )" & " " & "لا يوجد فى الكلمات": Exit Sub   ' رسالة للمستخدم بأن المتغير غير موجود بالنطاق وانهاء الاجراء
    Else  ' اذا لم يتحقق الشرط
    ' CopyRange.Select
    SelectRange.Interior.ColorIndex = 38 ' قم بتلوين الخلية التى تحتوى المتغير باللون 38
End If ' انهاء الشرط

Application.ScreenUpdating = True ' اعادة تفعيل تحديث الشاشة
End Sub  ' انهاء الاجراء

المرفق لالالالالالالالالالالالالالالالالالالالالالالالالالالالالالالالا يوجد

طبق الكود كالتالى :

الخلية C1  أدخل فيها الحرف الذى تبحث عنه  ( يمكن عمل قائمة منسدلة فيها بالحروف )   

  النطاق من C2 الى C10 أدخل به مثلا مجموعة كلمات   وجرب الكود

أرجو أن أكون قد قدمت لكم شيئا جديدا و مفيدا  هذا من وجهة نظرى على الأقل و الرأى لحضراتكم - بعد تجربة الكود - فى النهاية

والسلام عليكم ورحمة الله وبركاته

  على الموضوع     على الشرح          عليك   ( باردة والله )    تحياتى   

معلش عشان أقول كل شىء صعب لكن أقدر أقولك باختصار الفكرة

أى تغير فى التكست بوكس firstname  يجعل التكست بوكس autoNumber  يزيد 1 على آخر مسلسل  فى الشيت

الخلية AA2  فى الشيت بتاخد قيمتها من  التكست بوكس Qawmi  فى الفورم  الذى تضع به الرقم القومى

الخلية AB2  فيها معادلة نستدعى فيها الدالة Function A_ID   وتطلع تاريخ الميلاد من الخلية AA2  التى بها الرقم القومى ( المتغير T  تكون قيمته 2 فى المعادلة)

التاريخ الذى يظهر  فى هذه الخلية  بياخده التكست بوكس BrirthDate فى الفورم

الخلية AF2 فيها معادلة نستدعى فيها الدالة Function A_ID   وتطلع النوع من الخلية AA2  التى بها الرقم القومى  ( المتغير T  تكون قيمته 3 فى المعادلة)

النوع الذى يظهر  فى هذه الخلية  بياخده التكست بوكس Gender فى الفورم

الخلية AC2  و AD2  و AE2 نستخدم فيها معادلة DATEDIF  لحساب السن ( أيام - شهور - سنوات )  من الخلية AB2  التى بها تاريخ الميلاد

والقيم الناتجة فى هذه الخلايا تظهر  فى الفورم   وبكده يكون الفورم  به كل البيانات التى تصدر الى الشيت مرة أخرى

بالنسبة للصور كما وضحت فى المشاركات السابقة     أرجو أن يكون الشرح وافى

  مش فاهم  أي حاجة فى أى حاجة  !!!!!!!!!!!!!!!   اللى فاهم  يا ريت يوضح  يمكن أقدر أساعد

بعد اذن أخى الغالى ياسر

الملف ده جاهز

Removing all spaces from text.rar

Removing all spaces from text.rar

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

حل رائع أخى الكريم  العيدروس

لو تسمح بالاضافة  السابقة ( ازالة اللون عن الخلايا المحددة باللون الأحمر سابقا  و تلوين الخلايا المحددة حاليا فقط )

أشكرك أخى الكريم على كلماتك . 

سبحان الله جائتنى فكرة  اليوم نفذت بها طلبك الأول

قم بانشاء مجلد جديد وسميه Image  وضع بداخله صورا  بامتداد jpg   وسمى هذه الصور 1 2 3 4 5  وهكذا 

وضع المرفق ده بجوار مجلد الصور  Image 

4 تاريخ الميلاد والسن والنوع.rar

في ٣٠‏/١١‏/٢٠١٥ ٩:٣١:١٢, Mahmoud330 said:

انتو فين انتووووووووووووووووووووو فين 

و الله العظيم

نحن هنا لكن طلبك محتاج شغل كتير  وهذا ما ينفر الأعضاء 

وحضرتك تعلم الدنيا ومشاغلها فأكيد محدش فاضى

أولا يجب أن تعلم أننى شخصيا لا أجيد التعامل مع الفورم

و أحب التعامل مع الشيت و الأكواد والمعادلات مباشرة

و حسب ما فهمت  أنا عملت المطلوب لكن مع بعض التعديلات   :

يتم استخدام  الفورم فى ادخال الاسم  والرقم القومى  فقط  

( باقى العناصر فى الفورم أنا سبتها لك مؤقتا لربما تطلب تعديلات )

بمجرد كتابة اسم فى الفورم تظهر قيمة المسلسل آليا وبناء عليه

يتم استدعاء صورة من المجلد  Image  الموجود فى نفس مسار ملف الاكسل

هذه الصورة اسمها يساوى قيمة المسلسل يعنى لو المسلسل 1 يتم استدعاء الصورة 1 فى الفورم  مثلا

ملحوظة مهمة : الصورة يجب أن تكون بالامتداد jpg  كما يجب أن يكون مجلد الصور  بجوار ملف الاكسل

بمجرد عمل حفظ للبيانات  يتم  ادخال البيانات الى الشيت و حساب تاريخ الميلاد والسن والنوع بالمعادلات ( عادية و udf )

تفضل جرب المرفق . بعد فك الضغط ستجد مجلد ( بداخله ملف اكسل + مجلد صور كمثال )   تحياتى

أخى الكريم أعانى من مشاكل فى رفع المرفق لذلك اقتصرت على رفع الملف  فقط

فقم بانشاء مجلد جديد وسميه Image  وضع بداخله صورا  بامتداد jpg   وسمى هذه الصور 1 2 3 4 5  وهكذا  تحياتى

2 تاريخ الميلاد والسن والنوع.rar