عبدالله باقشير

السلام عليكم حقيقة بدون حلفان انا لم افهم المطلوب نهائيا !!!!!!!!!!!!!!!!!!!!!!!!!

الاخ الفاضل/ محمد مصطفى 2011

وعليكم السلام الكود يترجم حسب الاسطر

هذه عينه لصاحب الملف ويمكنك اضافة ماتريد فقط غير في الكود اخر صف للبيانات

شاهد الرابط التالي http://www.officena.net/ib/index.php?showtopic=41211

السلام عليكم هو طلب لاحدهم في الموضوع http://www.officena.net/ib/index.php?showtopic=41132 جعلته هنا لتعم الفائدة المرفق اكسل 2003 اكسل 2007 Trans Prog.rar

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

وعليكم السلام هل هذا ما تقصد Private Sub UserForm_Initialize() Me.Width = Application.Width Me.Height = Application.Height End Sub

======================== الاخ الفاضل / احمد البحيري ======================== و

السلام عليكم حط هذه الصيغة في التنسيق الشرطي واعطي لها اي لون تختاره =AND(E2=0;F2<>0) ودمتم

السلام عليكم نعم كلامك صحيح يحتاج تكرار الامر على نطاق واسع برضه ابعدت الالوان لانها تتراكب فوق بعضها Option Explicit '''النطاق الذي تريد فحصه Const rAddres As String = "B4:B12" '''' خلية رقم الفحص Const vAddres As String = "F3" Sub kh_Test() Dim r%, rr% With Range(rAddres) .Cells(0, 2).Resize(1, 2).Value = Array("Addres", "Sum") With .Cells(1, 2).Resize(1, 2) Range(.Cells, .Cells.End(xlDown)).ClearContents End With For rr = 1 To .Rows.Count For r = rr To .Rows.Count SumTest .Cells, Range(.Cells(rr, 1), .Cells(r, 1)), Val(Range(vAddres)) SumTest .Cells, Union(.Cells(rr, 1), .Cells(r, 1)), Val(Range(vAddres)) Next Next End With End Sub Sub SumTest(MyRng As Range, TestCol As Range, MyVal As Double) Dim iCol As Range, Adr$ With MyRng For Each iCol In .Cells If WorksheetFunction.Sum(Union(iCol, TestCol)) = MyVal Then Adr = Union(iCol, TestCol).Address With Cells(Rows.Count, .Column + 1).End(xlUp).Offset(1, 0) If WorksheetFunction.CountIf(Columns(.Column), Adr) = 0 Then .Cells(1, 1).Formula = Adr .Cells(1, 2).Formula = "=SUM(" & Adr & ")" End If End With End If Next End With End Sub شاهد المرفق للتجربة 2003 سيناريو التجميع 2.rar

السلام عليكم جمعة مباركة نسخنا ورقة الويب الى الملف وعملنا جدول منها لاستخدامه في فورم لاظهار الالوان شاهد المرفق 2003-2007 الوان الويب.rar

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

الاخ الفاضل / يحياوي__________ حفظه الله و

الفكرة تبدا حبة حبة وبعده يتم التطوير مع الوقت ان شاء الله تقبلوا تحياتي وشكري

السلام عليكم حذف اشكال تلقائية والصور والنماذج في نطاق معين اشتغل معي عل اوفيس 2003 حدد النطاق داخل الكود مثلا If Not Intersect(shp.BottomRightCell.Cells, .Range("A1:H100").Cells) Is Nothing Then Sub kh_shp_Delete() Dim R As Integer Dim shp As Shape With Cells.Worksheet For Each shp In .Shapes If Not Intersect(shp.BottomRightCell.Cells, .Range("A1:H100").Cells) Is Nothing Then shp.Delete End If Next shp End With End Sub المرفق 2003 حذف اشكال تلقائية والصور والنماذج في نطاق معين.rar

جزاك الله خيرا وبارك الله فيك تقبل تحياتي وشكري

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

السلام عليكم هو طلب لاحدهم وضعته هنا لعموم الفائدة http://www.officena.net/ib/index.php?showtopic=41089 دائما نكون محتاجين عمودين بجانب النطاق لوضع السيناريو عنوان خلايا الجمع وحاصل نتيجة الجمع غير معطياتك بداية الكود Option Explicit '''النطاق الذي تريد فحصه Const rAddres As String = "B4:B12" '''' خلية رقم الفحص Const vAddres As String = "F3" وهذا الكود Option Explicit '''النطاق الذي تريد فحصه Const rAddres As String = "B4:B12" '''' خلية رقم الفحص Const vAddres As String = "F3" Dim cd Sub kh_Test() Dim r%, rr% cd = 8 With Range(rAddres) .Interior.ColorIndex = xlNone .Offset(0, 1).Resize(, 2).ClearContents .Cells(0, 2).Resize(1, 2).Value = Array("Addres", "Sum") For rr = 1 To .Rows.Count For r = rr To .Rows.Count SumTest .Cells, Union(.Cells(rr, 1), .Cells(r, 1)), Val(Range(vAddres)) Next Next End With End Sub Sub SumTest(MyRng As Range, TestCol As Range, MyVal As Double) Dim iCol As Range, Adr$ With MyRng For Each iCol In .Cells If WorksheetFunction.Sum(Union(iCol, TestCol)) = MyVal Then If kh_tColor(Union(iCol, TestCol)) Then Adr = Union(iCol, TestCol).Address With .Offset(.Rows.Count, 1).End(xlUp).Offset(1, 0) .Resize(1, 2).Value = Array(Adr, "=SUM(" & Adr & ")") End With Union(iCol, TestCol).Interior.ColorIndex = cd cd = cd + 1 Exit For End If End If Next End With End Sub Function kh_tColor(Col As Range) As Boolean Dim T As Range For Each T In Col.Cells If T.Interior.ColorIndex = xlNone Then kh_tColor = True Exit For End If Next End Function المرفق 2003 2007 حاصل جمع.rar ========================================== التحديث الاخير للكود في 18-2-2015 المرفق 2010 سيناريو توافيق تجميع قيم تعطي نتيجة معينة.rar

السلام عليكم اولا لا تنسى تمكين الماكرو وايضا دائما نكون محتاجين عمودين بجانب النطاق لوضع السيناريو عنوان خلايا الجمع وحاصل نتيجة الجمع غير معطياتك بداية الكود Option Explicit '''النطاق الذي تريد فحصه Const rAddres As String = "B4:B12" '''' خلية رقم الفحص Const vAddres As String = "F3" وهذا الكود Option Explicit '''النطاق الذي تريد فحصه Const rAddres As String = "B4:B12" '''' خلية رقم الفحص Const vAddres As String = "F3" Dim cd Sub kh_Test() Dim r%, rr% cd = 8 With Range(rAddres) .Interior.ColorIndex = xlNone .Offset(0, 1).Resize(, 2).ClearContents .Cells(0, 2).Resize(1, 2).Value = Array("Addres", "Sum") For rr = 1 To .Rows.Count For r = rr To .Rows.Count SumTest .Cells, Union(.Cells(rr, 1), .Cells(r, 1)), Val(Range(vAddres)) Next Next End With End Sub Sub SumTest(MyRng As Range, TestCol As Range, MyVal As Double) Dim iCol As Range, Adr$ With MyRng For Each iCol In .Cells If WorksheetFunction.Sum(Union(iCol, TestCol)) = MyVal Then If kh_tColor(Union(iCol, TestCol)) Then Adr = Union(iCol, TestCol).Address With .Offset(.Rows.Count, 1).End(xlUp).Offset(1, 0) .Resize(1, 2).Value = Array(Adr, "=SUM(" & Adr & ")") End With Union(iCol, TestCol).Interior.ColorIndex = cd cd = cd + 1 Exit For End If End If Next End With End Sub Function kh_tColor(Col As Range) As Boolean Dim T As Range For Each T In Col.Cells If T.Interior.ColorIndex = xlNone Then kh_tColor = True Exit For End If Next End Function المرفق 2003 2007 حاصل جمع.rar

السلام عليكم لكن قد يكون هناك اكثر من سيناريو عموما تفضل الكود كبداية تصور لمقارنة خليتين كحد اعلى ده كود على السريع Sub kh_Test() Dim c As Range, co As Range Range("F4:F12").Interior.ColorIndex = xlNone For Each c In Range("F4:F12").Cells If Val(c) = Val([i3]) Then c.Interior.ColorIndex = 15: Exit For End If For Each co In Range("F4:F12").Cells If Intersect(c, co) Is Nothing Then If WorksheetFunction.Sum(Union(c, co)) = Val([i3]) Then Union(c, co).Interior.ColorIndex = 15 Exit For End If End If Next Next End Sub

السلام عليكم احبائي طارق محمود , دغيدي , محمد يحياوي --------------حفظكم الله و جزاكم خيرا ========================== لائراء الموضوع هل بالامكان حذف الصور اعتمادا على عنوان نطاق يعني الموجودة داخل هذه الخلايا من النطاق المعين جربوا هذا الكود Sub kh_shp_Delete() Dim R As Integer Dim shp As Shape With ActiveSheet For Each shp In .Shapes If Not Intersect(shp.BottomRightCell.Cells, .Range("B4:K17").Cells) Is Nothing Then shp.Delete End If Next shp End With End Sub ودمتم في حفظ الله

الاخ الفاضل / الجزيرة__________ حفظه الله الاخ الفاضل / قصي__________ حفظه الله الاخ الفاضل / محمدي__________ حفظه الله تقبلوا تحياتي وشكري ودمتم في حفظ الله

======================== الاخ الحبيب/ طارق محمود ======================== و

الاخ الفاضل/ الخالدي -----------حفظه الله الاخ الفاضل/ رجب جاويش------حفظه الله