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

أخى صلاح   أخى الشيبانى بارك الله فيكما تقبلا تحياتى

بإذن الله تحل المشكلة

بعدها حاول ارفاق ملف فيه بيانات و وضح ما تريد فيه 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    If Not Intersect(Target, Range("I4:N11")) Is Nothing Then Target = Format(Now, "dd-mm-yyyy")
      
End Sub

أخى الشيبانى   تحياتى

يا أبا الحسن الحسين أحسنت و بارك الله فيك 

يمكن أيضا جعل الباسورد من حروف و أرقام متغيرة 

شاشة دخول الباسورد متغير حرفى رقمى عشوائي.rar

شاشة دخول الباسورد متغير حرفى رقمى عشوائي بالمحاولات.rar

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

رووووووووووووووووووووووح يا شيخ  منك لـ  اللى  كلت دراع جوزها 

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

حبذا لو تضيف عدد محدد من المحاولات بعدها  يغلق الملف 

أخى عبدالله هذا الموضوع مكرر 

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

انظر الى الموضوع التانى هتلاقى مشاركة لى هناك    أرجو أن تكون وصلت الفكرة

ادراج التاريخ من خلال وضع الماوس على الخلية.rar

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

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

أخى فارس التاريخ يتغير كلما نقرت على الخلية

حدث الورقة : اعمل كليك يمين على اسم الورقة أو الشيت  ستجد كلمة View code  اضغط عليه هتلاقى نافذة محرر الاكواد للورقة أمامك

جرب

2 تنسيق شرطي للصف.rar

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    If Not Intersect(Target, Range("I4:N11")) Is Nothing Then Target = Format(Now)
      
End Sub

ضع  الكود السابق فى حدث الورقة  ثم احفظ الملف بصيغة  XLS  أو XLSM

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

بارك الله فيك أخى العيدروس  حزاك الله خيرا   تحياتى لشخصكم الكريم

ما شاء الله عليك رائع أخى الكريم  جعل فى ميزان حسناتك

أخى العيدروس عمل رائع بارك الله فيك بس فيه ملحوظتين

جربت ادخال  التاريخين من 1/11/2015  الى 10/11/2015 وحدث الآتى

اسم محمد تكرر فى هذه الفترة مرتين  بينما يظهر فى الليبل  أنه تكرر   صفر

لى طلب  :  تبدأ بالبيانات فى النتائج بالتاريخ ثم  الباقى ثم   ثم

أرجوا أن تظهر البيانات  فى الفورم  كالتالى :  رقم العميل  اسم  العميل  كود الصنف ......وهكذا

تحياتى

نعم الحمد لله الذى بنعمته تتم الصالحات

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

أخى و حبيبى في الله و أستاذى ياسر بارك الله فيك ... ما أروعك ! وما أروع تلك الأثرة فيك !

لولا فضل من الله و لولا تدخلك ما وصلنا الى هذه النتيجة الرائعة

بارك الله فيك و فى أهلك و فى مالك و فى وقتك و و فقك فى خدمة اخواننا فى كل مكان

فلك مني كل التحية و التقدير

نعم مكرر مع الاختلاف 

أنا وضعت الحل هنا ثم  تصادف أن المطلوب هناك مشابه تماما للموضوع  هنا

وتدخلت هناك بالتعديل على الحل الذى قدمه أخونا مصطفى. تحياتى

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

  http://www.officena.net/ib/topic/65138-%D8%B9%D9%85%D9%84-%D8%AF%D8%A7%D9%84%D8%A9-%D8%AA%D9%82%D9%88%D9%85-%D8%A8%D8%A7%D9%84%D8%AC%D9%85%D8%B9-%D9%88%D8%AA%D9%84%D9%88%D9%8A%D9%86-%D8%A7%D9%84%D8%AE%D9%84%D9%8A%D8%A9-%D8%B9%D9%86%D8%AF-%D8%B1%D9%82%D9%85-%D9%85%D8%B9%D9%8A%D9%86/

أخى الحبيب مصطفى بارك الله فيك  حللك جميل بس فيه ملاحظات

استخدام نفس التنسيق الشرطى مرة  على العمود E  ومرة على العمود  H  

فالأحرى  تطبيق التنسيق على النطاقين مرة واحدة طالما لهما نفس التنسيق

يعنى فى خانة    appliese to نضع  $H$6:$H$80;$E$6:$E$80=  

يوجد قيم خاطئة فى نتائج المعادلة بالعمودين E  و H   لأن فيه قيم نصية فى آخر العمودين

لذلك تم اضافة الدالة IFERROR   و اضافة تنسيق جديد  والتعديلات فى المرفق

المقارنة++++++.rar

أخى الكريم  

أولا تم تحويل النطاق d6:d15  من عدد عشرى  الى عدد صحيح

تم استخدام الدالة ABS لتحويل النتائج السالبة إلى موجبة 

تم استخدام التنسيق الشرطى كالتالى :

حدد نطاق التنسيق و من التنسيق الشرطي اختر New Rule ثم اختر الخيار الأخير ...... use a formula

فى خانة المعادلة  ضع المعادلة  D6>C6=                          و على تنسيق Format واختر اللون المناسب (  أخضر )    

كرر العملية السابقة  مع تغيير المعادلة  الى D6<C6=          و على تنسيق Format واختر اللون المناسب (  احمر )   

كرر العملية السابقة  مع تغيير المعادلة  الى D6=C6=          و على تنسيق Format واختر اللون المناسب (  برتقالى )   

لا تنسى تحديد نطاق التنسيق فى كل مرة .  اطلع على المرفق التالى

مقارنة 2.rar

مقارنة 2.rar

تمام كده 

أنا كنت بأجرب على مجموعة  من الملفات  دون غيرها لا يظهر معها هذا الخطأ 

ولهذا ذكرت أن الكود ليس به أخطاء خاصة و أن النتائج النهائية صحيحة 100 %  

نحن الآن بانتظار رأى أبو يوسف فى المرفق الأخير  يا رب يكون مرضى وصل لمبتغاه

أخى أبو يوسف 

أنا مجرب الملف قبلك  عدة مرات  و لا تظهر لى هذه الرسالة

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

وجرب  المرفق الأخير  فى مشاركتى الأخيرة   Collect Data From Multiple CSV Workbooks YasserKhalilMokhtar V 4.rar

أخى وأستاذى الغالى بارك الله فيك .

اكتشفت خطأ فى المعادلة SUMPRODUCT  و تم التصحيح  

أخى أبو يوسف  المرفق التالى  لحساب عدد التكرار لكل مكتب في جميع الاوراق 

هذا المرفق  به كودين يتم استدعائهما  بزر  واحد 

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

السطر التالى  فى الكود الاول يحذف

 Call CopyToNewSheet

أضف  شكلا تلقائيا  أو  زر و اربطه  بالكود الثانى 

  وأى ملاحظات أخرى فأهلا و سهلا بها  فلا تخجل    تحياتى لك ولأخى وأستاذى أبا البراء

Collect Data From Multiple CSV Workbooks YasserKhalilMokhtar V 4.rar

6 ساعات مضت, أحمــــد غانـــم said:

ما شاء الله

موضوع مميز و رائع بفكرته و تنفيذه

بارك الله جهودكم

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

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

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

Option Explicit

Sub CopyToNewSheet()
' by Mokhtar Hussien
' 25/11/2015
Dim SH As Worksheet
Dim P As Long
Dim Rng As Range
Dim Data, ColFound
Dim Obj As Object

Application.ScreenUpdating = False
Application.DisplayAlerts = False
 '-----------------------------------------------------------------
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "التجميعى"

 '-----------------------------------------------------------------
For Each SH In ThisWorkbook.Sheets
      If IsError(Application.Match(SH.Name, Array("Master", "التجميعى"), 0)) Then
        SH.Range("M2").CurrentRegion.Offset(1).Copy
        
        With Sheets("التجميعى")
              .Activate
              .Range("B1:C1") = Array("مكتب التربية", "العدد")
              .Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAll
              With .Range("B1").CurrentRegion
                   .Range("A1:B1").Interior.Color = vbYellow
                   .Borders.Weight = xlThin
                   .BorderAround Weight:=xlThick
                   .Columns.AutoFit
              End With
         End With
      End If
Next
 '-----------------------------------------------------------------
With Sheets("التجميعى")

     ColFound = Application.Match("*مكتب التربية*", .Rows(1), 0)
     If IsNumeric(ColFound) Then
        .Range("G2:H2") = Array("الاحصاء النهائى لمكاتب التربية", "الجملة")
        Set Rng = .Range(.Cells(2, ColFound), .Cells(.Cells(Rows.Count, ColFound).End(xlUp).Row, ColFound))
        Set Obj = CreateObject("scripting.dictionary")
        Data = Rng
        For P = 1 To UBound(Data)
            Obj(Data(P, 1) & "") = ""
        Next
        .Range("G3:G1000").ClearContents
        .Range("G3").Resize(Obj.Count, 1) = Application.Transpose(Obj.keys)
        '-----------------------------------------------------------------
        With .Range("H3:H" & .Cells(Rows.Count, "G").End(xlUp).Row)
             .Formula = "=SUMPRODUCT( (R2C2:R1000C2 =RC[-1]) * R2C3:R1000C3 )*2"
             .Value = .Value
        End With
        '-----------------------------------------------------------------
        With .Range("G2").CurrentRegion
             .Borders.Weight = xlThin
             .BorderAround Weight:=xlThick
             .Columns.AutoFit
             .Range("A1:B1").Interior.Color = vbYellow
         End With
         '-----------------------------------------------------------------
         .Columns("A:F").Delete Shift:=xlToLeft
         '-----------------------------------------------------------------
        End If
End With
 '-----------------------------------------------------------------
Sheets("Master").Activate
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = False
End Sub

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

Collect Data From Multiple CSV Workbooks Yasser Mokhtar final.rar

أخي الكريم أبو يوسف

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

منذ ساعه, محمد حسن المحمد said:

السلام عليكم ورحمة الله وبركاته   جزاكم الله خيراً على هذا العرض الطيب

لا إله إلا الله محمّد رسول الله

عليها نحيا وعليها نموت وعليها نبعث يوم الحشر

جميله جدا أخى ياسر بارك الله فيك