الـعيدروس

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

السلام عليكم ربما فهمت طلبك شوف الكود بيشيك على العمود "F" وبموجب الدمج الذي في العمود "F" بيعمل مثله في العمود "J" مع الاحتفاظ بقيم الخلايا المدموجه + جمعها بمعنى اذا العمود "F" ليس به خلايا مدموجه لم ينفذ شيء الكود جرب الكود Sub Ali_Merg() Dim Rng As Range Dim Rm As Range Dim My_r As Range Dim X_r As Double 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx For Each Rng In Range("F6:F20") If Rng.MergeCells Then If Not Rng Is Nothing Then If Rm Is Nothing Then Set Rm = Rng.Offset(0, 4) Else Set Rm = Union(Rm, Rng.Offset(0, 4)) End If End If Next 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx If Not Rm Is Nothing Then For Each My_r In Rm.Areas X_r = Alr_Cn(My_r) With My_r .ClearContents .Merge .Value = X_r End With Debug.Print X_r Next End If Set Rng = Nothing: Set Rm = Nothing Set My_r = Nothing 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx End Sub Private Function Alr_Cn(R As Range) As Currency Dim i Dim Sm As Double With R For i = 1 To .Rows.Count Sm = Sm + .Cells(i, 1) Next i If Sm Then Alr_Cn = Sm End With End Function تحياتي او هكذا حسب التحديد الحالي يعني تضلل مثلا 5 سطور وتظغط كنترول وتضلل 5 سطور اخر في العمود "J" وهكذا وبعد التضليل شغل الكود Sub Ali_Merg() Dim My_r As Range Dim X_r As Double 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx For Each My_r In Selection.Areas X_r = Alr_Cn(My_r) With My_r .ClearContents .Merge .Value = X_r End With Next Set My_r = Nothing 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx End Sub Private Function Alr_Cn(R As Range) As Currency Dim i Dim Sm As Double On Error Resume Next With R For i = 1 To .Rows.Count Sm = Sm + .Cells(i, 1) Next i If Sm Then Alr_Cn = Sm End With On Error GoTo 0 End Function

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

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

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

لاتنسى انه لن يتفعل على شرط الا بعد التاريخ او الايام المضافه؟ لذا اذا تاريخ اليوم لايساوي التاريخ المحدد المضاف له 3 يوم او 6 يوم او 9 يوم سيكون الباسورد 123 اذا اردت ان تعرف مااقصد اذهب الى السطر التالي في الداله Ch_Date = DateSerial(Year(Date), Month(Date), Day(Date)) وغيره بهذا اي بعد مرور 3 ايام Ch_Date = "2015/12/31" بعد الحفظ وفتح الملف مره اخرى لن يقبل الا بالباسورد "الحمد لله" شاشة دخول - تغيير الباسورد_111.rar

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

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

بالامكان على مااضن بهذي الطريقه Private Const Dat_On As String = "2015/12/28" '' التاريخ الاولي الذي يبداء العد من بعده Private Function Pass_My() As String Dim Vl1 As Date Dim Vl2 As Date Dim Vl3 As Date Dim Ch_Date As Date Dim Dt_on As Date '********************************* Dt_on = Dat_On Vl1 = VBA.DateAdd("d", 3, Dt_on) Vl2 = VBA.DateAdd("d", 6, Dt_on) Vl3 = VBA.DateAdd("d", 9, Dt_on) Ch_Date = DateSerial(Year(Date), Month(Date), Day(Date)) If Ch_Date = Vl1 Then Pass_My = "الحمد لله" ElseIf Ch_Date = Vl2 Then Pass_My = "الله اكبر" ElseIf Ch_Date = Vl3 Then Pass_My = "سبحان الله" End If '********************************* End Function وتستدعي الدالة من السطر التالي If TextBox1.Text = "123" Then ليكون بالشكل التالي If TextBox1.Text = Pass_My Then ارجو ان يفي بالغرض تحياتي

السلام عليكم الاخ الحبيب سعد عابد اسعد الله مساك شاهد المرفق هل هكذا تقصد جديد_111.rar

السلام عليكم الاخ الفاضل صالح احمد ابو يوسف افتح موضوع جديد لطلبك ولن يقصر معك الجميع كلن حسب وقته اخي ياسر خليل شاهد المرفق تقويم خاص لاادري لمن هو من ضمن الارشيف عدلنا عليه ان شاء الله يعمل معك عمل معي مع 64 بت اوفيس 2013 البحث بين تاريخين_A3.rar

حفظك الله اخي ياسر خليل كلنا نتعلم من بعض احبك الله الذي احببتنا فيه تقبل تحياتي وشكري لشخصكم النبيل

المشكله عندك اخي هل انت مفعل امان الماكرو منخفض ام لا ؟ اتبع الفيديو في المرفق اذا لاتعرف الطريقه لتفعيل الماكرو تفعيل الماكرو.rar

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

بالطبع اخي مختار حسين لان الاسم خلال الفترة لم يذكر اكثر من رمره لذا لايوجد تكرار ! اما ماذكرته : يوجد خلل بسيط في كود حدث "Calendar1_Click" في الفورم المسمى "Celndr_Ali" Ali_Rep.Controls(A_Se).Value = Calendar1.Value يستبدل بالتالي لعمل عليه فورمات ليأتي بالتاريخ بالشكل الذي نريده "yyyy/mm/dd" Ali_Rep.Controls(A_Se).Value = Format(Calendar1.Value, "yyyy/mm/dd") اذهب الى كود "ListBox1_Click" في السطر الحلقة التكراريه For ii = 1 To .ListCount - 1 الصح بيكون من 0 كأول سطر في الليست بوكس كالتالي For ii = 0 To .ListCount - 1 اذهب الى خصائص فورم "Ali_Rep" وروح الى خاصية "RightToleft" قيمتها False حولها الى True ان شاء الله ستظهر كما تريد او ضيف السطر التالي في حدث "UserForm_Initialize" Me.RightToLeft = True المرفق بعد تعديل ماذكر مسبقاً البحث بين تاريخين_A2.rar

السلام عليكم ان كان كجمال واعطاء مساحه احبذ الكود التالي عند فتح المصنف "Auto_Open" ينفذ اخفاء عند اغلاق المصنف "Auto_Close" ينفذ اظهار Sub Auto_Open() Ali_Acc False End Sub Sub Auto_Close() Ali_Acc True End Sub Sub Ali_Acc(Bll As Boolean) With Application .DisplayFormulaBar = Bll .ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"" ," & Bll & ")" .ActiveWindow.DisplayHeadings = Bll If Bll Then .ThisWorkbook.Close SaveChanges:=Not Bll End With End Sub

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

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

تفضل المرفق الاول الشرح و المرفق الاخر الملف وبه الإضافه الاخ الفاضل ياسر اولا اضفنا ليبل وسميناه "Cu" واضفنا لكود حدث "ListBox1_Click" الاسطر التاليه For ii = 1 To .ListCount - 1 If Not .List(ii, 1) = vbNullString Then If CStr(.List(ii, 1)) Like CStr(.List(.ListIndex, 1)) Then Ct = Ct + 1 End If Next ii If Ct Then Cu.Visible = True: Cu.Caption = "تكرر العميل : " & "( " & CStr(.List(.ListIndex, 1)) & " )" & " خلال الفترة " & IIf(Ct = 1, 0, Ct) & " مرات " ليصبح Private Sub ListBox1_Click() Dim Rn As Range Dim ii, Ct On Error GoTo 1 With Me.ListBox1 Set Rn = Range(.List(.ListIndex, 6)).Resize(, 6) With Rn .Activate End With For ii = 1 To .ListCount - 1 If Not .List(ii, 1) = vbNullString Then If CStr(.List(ii, 1)) Like CStr(.List(.ListIndex, 1)) Then Ct = Ct + 1 End If Next ii If Ct Then Cu.Visible = True: Cu.Caption = "تكرر العميل : " & "( " & CStr(.List(.ListIndex, 1)) & " )" & " خلال الفترة " & IIf(Ct = 1, 0, Ct) & " مرات " End With Set Rn = Nothing 1 End Sub شرح_6.rar البحث بين تاريخين_A1.rar

ماهي التي لم تشتغل معك ؟ تأكد من اعدادات امان الماكرو يوجد ايميل Gmail aahfm2015@Gmail.com

السلام عليكم المرفق الاول شرح طريقة العمل عليه والمرفق الاخر الملف وبه تعديل بعض الاخطاء البحث بالتاريخ لن يعمل معك اكتب التاريخ في الورقة "الصفحة 01" بالصيغة الصحيحه وسيعمل معك لاني ملاحظ مكتوب 01/01/00 ؟ توضيح.rar تجربة_112.rar

تمت اضافة المرفق في المشاركة السابقة اخي مشاكس يقصد الاستاذ ياسر خليل اسم ظهورك تغيره كأسم عربي بدلاً عن "MoChekEs"

السلام عليكم انسخ الكود التالي الى حدث الورقة المسماه "الصفحة 2" Private Const My_Rng_Adrs As String = "$A$3:$D$55000" Private Const Area_Prnt As String = "$C$7:$E$15" Dim Ar_1() As Variant Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Range("A7:A1000"), Target) Is Nothing Then MsgBox "" If Target <> Empty Then Dim Wr As Worksheet: Set Wr = Sheets("الصفحة 3") With Wr .Cells(7, 4) = Target .Cells(8, 4) = Target.Offset(0, 1) .Cells(9, 4) = Target.Offset(0, 2) .PageSetup.PrintArea = Area_Prnt .PrintPreview .Cells(7, 4) = "": .Cells(8, 4) = "": .Cells(9, 4) = "" End With Cancel = False Set Wr = Nothing End If End If End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$A$5" Then Range(Range("A7"), Range("D7").End(xlDown).Resize(1, 4)).ClearContents If Ali_Serch(CStr(Target), 1) = True Then Range("A7").Resize(UBound(Ar_1, 1), UBound(Ar_1, 2)) = Ar_1() End If Erase Ar_1 End If If Target.Address = "$C$5" Then Range(Range("A7"), Range("D7").End(xlDown).Resize(1, 4)).ClearContents If Ali_Serch(CDate(Target), 3) = True Then Range("A7").Resize(UBound(Ar_1, 1), UBound(Ar_1, 2)) = Ar_1() End If Erase Ar_1 End If If Target.Address = "$E$5" Then Range(Range("A7"), Range("D7").End(xlDown).Resize(1, 4)).ClearContents If Ali_Serch(CStr(Target), 4) = True Then Range("A7").Resize(UBound(Ar_1, 1), UBound(Ar_1, 2)) = Ar_1() End If Erase Ar_1 End If End Sub Private Function Ali_Serch(Trget As String, Col As Long) As Boolean Dim Ar Dim Rng As Range Dim C, x, i, XX, Xi, Xt Dim Data_1 Dim Wrsh As Worksheet Set Wrsh = Sheets("الصفحة 01") With Wrsh If Col = 3 And Not IsDate(Trget) Then MsgBox "صيغة التاريخ التي كتبتها غير صحيحه !!", vbExclamation, "إدخال خاطئ !!": Exit Function Set Rng = .Range(My_Rng_Adrs) Ar = Rng.Value ReDim Preserve Ar_1(1 To Rng.Rows.Count, 1 To 4) For x = LBound(Ar, 1) To UBound(Ar, 1) XX = Ar(x, Col): Xi = Trim(Ar(x, 1)): Xt = Trim(Ar(x, 2)) If Col = 3 Or Col = 4 Then Data_1 = Val(XX) ElseIf Col = 1 Then Data_1 = CStr(Xi & " " & Xt) ElseIf Col = 3 Then Data_1 = CDate(DateSerial(Year(XX), Month(XX), Day(XX))) End If If Not Data_1 = Empty Then If Data_1 Like Trget Then Ali_Serch = True i = i + 1 For C = 1 To 4 Ar_1(i, C) = IIf(C = 3, Format(Ar(x, C), "dd/mm/yy"), CStr(Ar(x, C))) Debug.Print Ar(x, C) Next C End If End If Next x End With Set Rng = Nothing: Set Wrsh = Nothing End Function بعد كتابة الاسم او التاريخ او رقم التسجيل اضغط انتر ستظهر النتائج اسفل جدول البحث انقر مرتين على نتيجة البحث في العمود "A" الاسم الاول سيطبع لك النتيجه جرب وابلغنا بالنتائج تحياتي تم اضافة المرفق وبه الكود اعلاه تجربة_111.rar

اخي الكريم ياسر خليل الفائده من استخدام الكود بالطريقه التي سردتها بالمشاركه السابقه ان لاتحمل كاهل الملف بالهيبرلينك حتى يصبح بطيئ جدا عند الفتح وان ولايوقف عند الخليه 650000 كحد اعلى للهيبرلينك فقط بل ينفذ الكود حتى يصل عند التوليف "ZZZZ" كأنه كتب عنوان على الخلايا فقط ونستخدم العنوان كهيبر لينك عند النقر عليه وبالامكان استخدام الكود لايحذف الهيبرلينك الا حين يصل الى الحد الاعلى بإضافة بسيطه هذه اضافه لااحبذها الافضل التعامل مع كل خليه كي لا يكبر حجم الملف ويصبح بطيئ هذا المرفق وبه الكود لحدث الصفحه وكود انشاء العناوين If ActiveSheet.Hyperlinks.Count >= 65530 Then For Each R In ActiveSheet.Hyperlinks If R.TextToDisplay > "" Then R.Delete: Exit For Next End If شرح كود الهايبر لنك_111.rar

السلام عليكم اخي ياسر خليل ماقصدت الوصول اليه بهذا الشكل كي تتضح لديك الصورة اي اننا لن نصل للحد الاعلى من الهيبر لينك نستخدم الخليه الحاليه هيبرلينك ومجرد استخدامنا للخليه الحاليه نحذف السابق ارجو ان وصلت الفكره Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, ActiveSheet.UsedRange) Is Nothing Then Dim R As Hyperlink For Each R In ActiveSheet.Hyperlinks If R.TextToDisplay > "" Then R.Delete Next With ActiveSheet .Hyperlinks.Add Anchor:=Target, Address:=Target, SubAddress:="", TextToDisplay:=CStr(Target.Text) End With Set R = Nothing End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, ActiveSheet.UsedRange) Is Nothing Then Dim R As Hyperlink For Each R In ActiveSheet.Hyperlinks If R.TextToDisplay > "" Then R.Delete Next With ActiveSheet .Hyperlinks.Add Anchor:=Target, Address:=Target, SubAddress:="", TextToDisplay:=CStr(Target.Text) End With Set R = Nothing End If End Sub