الخالدي

السلام عليكم ورحمة الله وبركاته في الكود التالي وضعت النطاقات في اكثر من Range Private Sub Worksheet_Change(ByVal Target As Range) Set Rn = Range("K11:K2000,L11:L2000,O11:O2000,P11:P2000,Q11:Q2000,R11:R2000,V11:V2000,W11:W2000,Z11:Z2000,AA11:AA2000") Set Rn = Union(Rn, Range("AB11:AB2000,AC11:AC2000,AG11:AG2000,AH11:AH2000,AK11:AK2000,AL11:AL2000,AM11:AM2000,AN11:AN2000,AS11:AS2000,AT11:AT2000,AY11:AY2000,AZ11:AZ2000")) Set Rn = Union(Rn, Range("BA11:BA2000,BB11:BB2000,BG11:BG2000,BH11:BH2000,BM11:BM2000,BN11:BN2000,BO11:BO2000,BP11:BP2000,BT11:BT2000,BU11:BU2000,BX11:BX2000,BY11:BY2000,BZ11:BZ2000")) Set Rn = Union(Rn, Range("CA11:CA2000,CF11:CF2000,CG11:CG2000,CL11:CL2000,CM11:CM2000,CN11:CN2000,CO11:CO2000,CQ11:CQ2000,CR11:CR2000,CS11:CS2000,CT11:CT2000,CU11:CU2000,CV11:CV2000,CW11:CW2000,CX11:CX2000,CY11:CY2000,CZ11:CZ2000")) Set Rn = Union(Rn, Range("DA11:DA2000,DC11:DC2000,DG11:DG2000,DH11:DH2000,DK11:DK2000,DL11:DL2000,DM11:DM2000,DN11:DN2000,DR11:DR2000,DS11:DS2000,DV11:DV2000,DW11:DW2000,DX11:DX2000,DY11:DY2000")")) Set Rn = Intersect(Target, Rn) If Not Rn Is Nothing Then Rn.Interior.ColorIndex = xlNone For Each cl In Rn If cl = "غ" Then cl.Interior.ColorIndex = 42 Else If cl <> "" And cl < Cells(10, cl.Column) Then cl.Interior.ColorIndex = 44 End If Next End If Set Rn = Nothing End Sub في الكود التالي وضعت النطاقات في Range واحد وبعدد احرف لا تزيد عن 256 حرفا حيث: تم وضع الاعمدة المتجاورة مثل K11:K2000 و L11:L2000 في نطاق واحد K11:L2000 عدم كتابة ارقام الصفوف مثل K11:L2000 اصبح K:L ثم بعد ذلك تم تحديد صفوف النطاقات من خلال التقاطع مع Range("11:2000") Private Sub Worksheet_Change(ByVal Target As Range) Dim Rn As Range, cl As Range Set Rn = Intersect(Target, Range("11:2000") , Range("K:L,O:O,P:R,V:V,V:W,Z:Z,AA:AC,AG:AG,AG:AH,AK:AK,AL:AN,AS:AS,AS:AT,AY:AY,AZ:BB,BG:BG,BG:BH,BM:BM,BN:BP,BT:BT,BT:BU,BX:BX,BY:CA,CF:CF,CF:CG,CL:CL,CM:CO,CQ:CQ,CR:DA,DC:DC,DG:DG,DG:DH,DK:DK,DL:DN,DR:DR,DR:DS,DV:DV,DW:DY")) If Not Rn Is Nothing Then Rn.Interior.ColorIndex = xlNone For Each cl In Rn If cl = "غ" Then cl.Interior.ColorIndex = 42 Else If cl <> "" And cl < Cells(10, cl.Column) Then cl.Interior.ColorIndex = 44 End If Next End If Set Rn = Nothing End Sub استخدم احدى الطرقتين في أمان الله

السلام عليكم ورحمة الله وبركاته الاستاذ الفاضل والاخ الحبيب العيدروس كل عام وانتم بألف خير واسمح لي بطرح كود اخر كنت قد جهزته قبل قليل وان كان ليس بنفس كفاءة وبساطة الكود الذي تفضلتم بوضعه الكود يعمل ايضا عند تغير كلمة مدين ودائن فربما هذا يهم صاحب الموضوع ملاحظة : كلمة مدين ودائن في ملف صاحب الموضوع تحتوي على مسافة زائدة لذا عليه بتصحيح الكلمات او اضافة مسافة للكلمات في الكود الكود في حدث الورقة Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Not Intersect(Target, [D7:E13]) Is Nothing Then For Each cl In Intersect(Intersect(Target, [D7:E13]).EntireRow, [D7:E13]).Columns(2).Cells If CStr(cl.Offset(0, -1)) = "مدين" Then If IsNumeric(cl) Then If cl <> Abs(cl) Then cl.Value = Abs(cl) ElseIf CStr(cl.Offset(0, -1)) = "دائن" Then If IsNumeric(cl) Then If cl <> (Abs(cl) * -1) Then cl.Value = (Abs(cl) * -1) End If Next End If End Sub في أمان الله

اخي العزيز يوسف كل عام وانتم بخير نسال الله لنا جميعا الوقوف بعرفات في البداية ارجوا تعديل السطر في الكود الاول من مشاركتي السابقة من If cl < Cells(10, cl.Column) Then cl.Interior.ColorIndex = 44 الي (السبب حتى لا يتم تلوين الخلايا الفارغة) If cl <> "" And cl < Cells(10, cl.Column) Then cl.Interior.ColorIndex = 44 --------------------------------- اما عن سبب الخطأ في الكود فمن خلال تجربتي للكود لوحظ انه عندما تكون النطاقات المحددة داخل Range() تزيد احرفها عن 256 حرفا يظهر خطأ في الكود , واعتقد ان هذا سبب الخطأ والحل باعتقادي يكون من خلال استخدام اكثر من Range() بحيث توضع داخل كلا منها عدد من النطاقات ثم يقوم الكود بمعالجة كل مجموعة على حده. ملاحظة : تأكد من صحة النطاقات DR11:DRY2000 و DW11:DWY2000 في Range() فربما انك تعني تحديد النطاقات DR11:DR2000 و DW11:DW2000 --------------------------------- بخصوص سؤالك في المشاركة قبل السابقة - ما العمل لو كنت سأستخدم الكود مع نتائج معادلات ؟؟ حقيقة لا اعلم الحل ربما يجود الاخوة بحل مناسب واقترحي لحل الموضوع: اذا كانت المعادلات مرتبطة بخلايا على نفس الصف فيمكن وضع شرط بالكود بالتنفيذ عند وجود تغيرات في الصفوف ويكون تنفيذ الكود فقط على خلايا النطاق المحدد والتي علي نفس الصف ويكون ذلك بتعديل Target الى Target.EntireRow في الكود الاول اما اذا كانت المعادلات مرتبطة بخلايا ليست على نفس الصف وايضا قد تكون مرتبطة بأوراق اخرى فاعتقد الحل يكون بوضع الكود في حدث Private Sub Worksheet_Calculate() واذا كان هناك بعض الخلايا يتم الادخال فيها بدون معادلات فيلزم هنا ايضا كود في حدث التغير بالورقة , الكود مع الحدث الحساب Calculate سيكون بطي لان الكود سينفذ على كل خلايا النطاق المحدد في أمان الله

جرب الكود المرفق ارجوا ان يفي بالغرض والكود يحتاج الى تعديل في حال المطلوب اظهار بقية اوراق الملف الى جانب الاوراق المحددة مثال.rar

عذار اخي يوسف لتأخري بالرد عليك وذلك بسبب ظروف عملي لم توضح الفرق من اي ناحية فالكود الاول سريع ويقوم فقط بتلوين الخلايا التي تم فيها التغير في النطاق المحدد(الاعمدة المحددة) ويعاب عليه انه لن يقوم بتلوين الخلايا التي تحقق الشرط قبل وضع الكود في حدث الورقة. الكود الثاني بطئ ويقوم بتلوين كل الخلايا في النطاق التي حدث فيها تغير ام لم يحدث فيها تغير (اي اعادة تحديث الوان كل خلايا النطاق) ايضا هناك عيب في الكود الاول والثاني وهو عدم قيام الكود بالتنفيذ عند تغير قيم خلايا النطاق بواسطة معادلات ------------------- الاكود بعد التعديل لكى يكون لحرف غ لون آخر الكود الاول Private Sub Worksheet_Change(ByVal Target As Range) Dim Rn As Range, cl As Range Set Rn = Intersect(Target, Range("G11:G2000,I11:I2000,K11:K2000,M11:M2000,N11:N2000,P11:P2000,S11:S2000,V11:V2000")) If Not Rn Is Nothing Then Rn.Interior.ColorIndex = xlNone For Each cl In Rn If cl = "غ" Then cl.Interior.ColorIndex = 42 Else If cl < Cells(10, cl.Column) Then cl.Interior.ColorIndex = 44 End If Next End If Set Rn = Nothing End Sub الكود الثاني Private Sub Worksheet_Change(ByVal Target As Range) Dim Rn As Range, cl As Range Set Rn = Range("G11:G2000,I11:I2000,K11:K2000,M11:M2000,N11:N2000,P11:P2000,S11:S2000,V11:V2000") If Not Intersect(Target, Rn) Is Nothing Then Application.ScreenUpdating = False: Application.EnableEvents = False For Each cl In Rn If cl = "غ" Then If cl.Interior.ColorIndex <> 42 Then cl.Interior.ColorIndex = 42 Else If cl <> "" And cl < Cells(10, cl.Column) Then If cl.Interior.ColorIndex <> 44 Then cl.Interior.ColorIndex = 44 Else If cl.Interior.ColorIndex <> xlNone Then cl.Interior.ColorIndex = xlNone End If End If Next Application.EnableEvents = True: Application.ScreenUpdating = True End If Set Rn = Nothing End Sub

السلام عليكم ورحمة الله وبركاته بعد اذن الاخوة الكرام اخي لحامد الشاكر حسب فهمي للمطلوب ادخل المعادلة التالية في الخلية E3 واسحبها للأسفل: =INDEX(($P$4;$R$4);;;MATCH(1;INDEX((COUNTIF(INDIRECT({"P5:P21","R5:R47"});D3)>0)*1;);0)) في أمان الله

وهنا كود يعمل على كامل النطاق Private Sub Worksheet_Change(ByVal Target As Range) Dim Rn As Range, cl As Range Set Rn = Range("G11:G2000,I11:I2000,K11:K2000,M11:M2000,N11:N2000,P11:P2000,S11:S2000,V11:V2000") If Not Intersect(Target, Rn) Is Nothing Then Application.ScreenUpdating = False: Application.EnableEvents = False Rn.Interior.ColorIndex = xlNone For Each cl In Rn If cl <> "" And (cl = "غ" Or cl < Cells(10, cl.Column)) Then If cl.Interior.ColorIndex <> 44 Then cl.Interior.ColorIndex = 44 End If Next Application.EnableEvents = True: Application.ScreenUpdating = True End If Set Rn = Nothing End Sub

السلام عليكم ورحمة الله وبركاته كما ذكر اخي الاستاذ أبو حنين بان الكود سيكون بطئ اذا تم التطبيق على كامل النطاق المطلوب , لذا الكود التالي يعمل فقط على الخلايا المتغيرة في النطاق المطلوب Private Sub Worksheet_Change(ByVal Target As Range) Dim Rn As Range, cl As Range Set Rn = Intersect(Target, Range("G11:G2000,I11:I2000,K11:K2000,M11:M2000,N11:N2000,P11:P2000,S11:S2000,V11:V2000")) If Not Rn Is Nothing Then Rn.Interior.ColorIndex = xlNone For Each cl In Rn If cl = "غ" Or cl < Cells(10, cl.Column) Then cl.Interior.ColorIndex = 44 Next End If Set Rn = Nothing End Sub ارجوا ان يكون المطلوب في أمان الله

بارك الله في استاذنا عبدالله باقشير وبعد الاذن الكود ادناه لحذف الاوراق التي تطابق اسمائها اسم العملاء ملاحظة : عند احتواء خلايا العميل على معادلات فان كود حذف اوراق العملاء و كود الاستاذ عبدالله باقشير الخاص بإنشاء الاوراق لا يعطيان النتائج المطلوبة Sub AL_KHALEDI() With Sheets("kh") Set Rng = Range(.Cells(6, 1), .Cells(.Rows.Count, 1).End(xlUp)) End With If Rng.Row < 6 Then GoTo Error Application.ScreenUpdating = False 10 NamSheet = Trim(Rng(1)) For Each itm In Array("/", "\", "*", ":", "؟", "?", "[", "]") NamSheet = Replace(NamSheet, itm, "") Next NamSheet = Mid$(NamSheet, 1, 31) If Len(NamSheet) <> 0 Then If Not IsError(Evaluate("'" & NamSheet & "'!A1")) Then Application.DisplayAlerts = False Sheets(NamSheet).Delete Application.DisplayAlerts = True End If End If On Error GoTo Error: Set Rng = Rng.ColumnDifferences(Rng(1)) GoTo 10 Error: Application.ScreenUpdating = True Set Rng = Nothing End Sub انشاء اوراق بحسابات العملاء.rar

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

سلمك الله اخي الاستاذ محمود وبارك الله فيك وفيما تقدمه من اعمال متميزة ورائعة نستفيد ونتعلم منها جميعا جرب المرفق اظهار الحساب المالي ومركز المسئولية لكل مبلغ4.rar

الله يسلمك اخي فهد شكرا للمرور الطيب

السلام عليكم جرب الكود التالي Sub AL_KHALEDI() Set Rn = Range("D3,D5:H7,D16:H25") Rn.Areas(3).ClearContents For c = 1 To Rn.Areas(2).Columns.Count: For r = 1 To Rn.Areas(2).Rows.Count If Rn.Areas(2)(r, c) Then v = v + 1 Rn.Areas(3)(v, 1) = Rn.Areas(2)(r, c) Rn.Areas(3)(v, 2) = Rn.Areas(1)(1, c) Rn.Areas(3)(v, 3) = Rn.Areas(2)(r, 0) Rn.Areas(3)(v, 4) = Rn.Areas(1)(2, c) End If Next: Next Set Rn = Nothing End Sub اظهار الحساب المالي ومركز المسئولية لكل مبلغ2.rar

السلام عليكم ورحمة الله وبركاته بارك الله بالأخوة الكرام حل اخر بالمعادلات اخي السائل جرب المعادلة التالية =SUMPRODUCT(($B$2:$B$17=A20)/COUNTIFS($A$2:$A$17;$A$2:$A$17&"";$B$2:$B$17;$B$2:$B$17&"")) في امان الله

مرفق تعديل للكود بعد حذف العمود C اذا كان لك استفسار سارد عليك بعد عودتي من سفر لعدة ايام وبخصوص : عمل فورم لادخال البيانات و شاشة دخول متعدد الصلاحيات لعدد 8 مستخدمين لم يسبق لي التعامل مع هذه الاكواد وستجد من الاخوة كل التعاون في امان الله ST2 (version 2).rar

اخي الكريم الكود يقوم بجمع القادمين في خلايا القادمين والمغادرين في خلايا المغادرين ولكل دولة على حدى مرفق الكود مع الملف في حال كانت النتائج غير صحيحة ارجوا توضيح المطلوب بدقة مع تحديد النتيجة المفترضة في امان الله ST2.rar

جرب الكود التالي على اكسل 2007 فما فوق Sub AL_KHALEDI() With Sheets("البيانات") Set Rn = Range(.Cells(4, 2), .Cells(Rows.Count, 2).End(xlUp)) Set Rn = Union(Rn, Range(.Cells(4, 12), .Cells(Rows.Count, 12).End(xlUp))) End With For A = 1 To 2 With Rn.Areas(A) c1 = IIf(A = 1, 0, -1): c2 = IIf(A = 1, 0, 5) For r = 0 To 1 Y = IIf(r = 0, "س", "م") Cells(14 + r, 3 + c2) = Application.CountIfs( _ .Columns(1), Y, _ .Columns(4 + c1), ">=" & [A9] * 1, _ .Columns(4 + c1), "<=" & [B9] * 1, _ .Columns(5 + c1), "*") For C = 0 To IIf(A = 1, 4, 5) - 1 Cells(14 + r, 4 + C + c2) = Application.SumIfs( _ .Columns(6 + C + c1), _ .Columns(1), Y, _ .Columns(4 + c1), ">=" & [A9] * 1, _ .Columns(4 + c1), "<=" & [B9] * 1) Next C Next r End With Next A Set Rn = Nothing End Sub

لا يعتمد الكود عند تجميع اوراق الشهر على التاريخ في الصف 3 , لكن الكود يعتبر اليوم الاول للشهر في العمود D واليوم الثاني في العمود E واليوم الثالث في العمود F وهكذا بالنسبة لإضافة اوراق فيمكن اضافة اوراق بأشهر السنة , اما في حالة اضافة اشهر ولعدة سنوات فيجب ان يتضمن اسم الورقة الشهر والسنة واضافة دالة للكود لتحديد السنة.

السلام عليكم ورحمة الله وبركاته بارك الله بالأستاذ الفاضل أبو حنين وهنا كود لأكثر من ورقة حسب فترة Sub AL_KHALEDI() L = Cells(Rows.Count, "C").End(xlUp).Row Set Rn1 = Range(Cells(4, "C"), Cells(L, "C")) Rn1.Offset(0, 1).ClearContents For r = 1 To Rn1.Rows.Count x = 0 For d = 0 To [D3] - [E3] Set Rn2 = Sheets("" & "شهر " & Month([E3] + d)) L = Rn2.Cells(Rows.Count, "C").End(xlUp).Row Set Rn2 = Range(Rn2.Cells(5, "C"), Rn2.Cells(L, "C")) m = Application.Match(Rn1(r, 1), Rn2, 0) If Not IsError(m) Then x = x + Rn2(m, 1 + Day([E3] + d)) End If Next d Rn1(r, 2) = x Next r Set Rn1 = Nothing: Set Rn2 = Nothing End Sub استدعاء بيانات لفترة.rar

السلام عليكم ورحمة الله وبركاته بارك الله بالأخوة الكرام جرب التنسيق المخصص التالي [$-2000000]_###_-###_-###_-##0 في أمان الله

السلام عليكم ورحمة الله وبركاته بعد اذن الاستاذ عبدالله لتصحيح الخطأ احذف احد السطرين Range("A6:A10000") = Empty Range(Cells(R, A), Cells(Range(A & 5000).End(xlUp).Row, A)).ClearContents بالرغم من ذلك سوف يحدث مشكلة , فالكود سوف يستمر بالعمل دون توقف بسبب ان الكود في حدث الورقة عند التغير والكود يقوم بتغيرات في خلايا في الورقة ولحل مشكلة الكود في حدث الورقة جرب الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) Static xxx If Not Intersect(Target, [A6:B1000]) Is Nothing Then If xxx = 1 Then Exit Sub On Error GoTo 10 Application.ScreenUpdating = False xxx = 1 L = Application.Max([A1000].End(xlUp).Row, [B1000].End(xlUp).Row) If L < 6 Then GoTo 10 Range(Cells(6, "A"), Cells(L, "A")) = Empty L = [B1000].End(xlUp).Row If L < 6 Then GoTo 10 For I = 6 To L If Cells(I, "A") = "" And Cells(I, "B") <> "" Then N = N + 1 For ii = I To [B1000].End(xlUp).Row If Cells(ii, "B") = Cells(I, "B") Then Cells(ii, "A") = N End If Next ii End If Next I 10 xxx = 0 Application.ScreenUpdating = True End If End Sub في أمان الله Copy of STAT-2.rar

السلام عليكم ورحمة الله وبركاته بارك الله فيكم اخي رجب واخي محمود وهنا كود اخر في حالة كان عدد الارقام في الخلية غير ثابت Sub AL_KHALEDI() [C2:C9000].ClearContents MyArr = 0 & "," & " " & "," For Each cl In [A2:A9000] x = cl.Value For r = 1 To Len(cl) If Len(Application.Substitute(cl, Mid(cl, r, 1), "")) <> Len(cl) - 1 Then x = " " Exit For End If Next r MyArr = MyArr & x & "," Next MyArr = Join(Filter(Filter(Split(MyArr, ","), 0, 0), " ", 0), ",") x = UBound(Split(MyArr, ",")) Cells(2, 3).Resize(x).Value = WorksheetFunction.Transpose(Split(MyArr, ",")) End Sub تصفية.rar

السلام عليكم ورحمة الله وبركاته اخي الكريم شاهد المرفق كشف حساب-كود3.rar

السلام عليكم ورحمة الله وبركاته انقر بزر الماوس الايمن على Module المطلوب حذفه , ثم من قائمة الماوس اختار Remove ثم اختار لا في حالة اختيار نعم يتم حذف الـ Module مع حفظه في المكان الذي تحدده , ويمكن استيراده الى نفس الملف او الى ملف اخر من خلال الامر Import File في قائمة الزر الايمن للماوس , ايضا الامر Export File في قائمة الزر الايمن للماوس يعمل على تصدير او حفظ الـ Module الى مجلد تحدده دون حذف الـ Module نفس الحال ينطبق على الـ UserForm الزر جلب البيانات في الورقة عميل2 يقوم بتنفيذ الماكرو AL_KHALEDI ولا اعلم ما هو الكود الخاص بالورقة ايضا الكود والاكواد الاخرى لن تعمل بسبب عدم تطابق النطاقات في الكود مع نطاقات البيانات الخاصة بالكود في الورقة . اذا كان وضع بيانات الاكود في خلايا الورقة يسبب لك مشاكل استخدم كود لا يعتمد على خلايا الورقة ساحاول من جانبي عمل الكود اذا توفر لدي وقت و اذا تم اعادة اصلاح الكهرباء في أمان الله

السلام عليكم ورحمة الله وبركاته الفاضل أبو أنس حاجب تقبل الله منا ومنكم صالح الاعمال بارك الله فيك ان شاء الله في موازين حسناتك في حفظ الله