التلوين الأوتوماتيكي أو التلقائي للخلايا انطلاقا من البيانات

[hassannahid05]

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

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

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

المطلوب : أن يلون هذا الجدول باللون البرتقالي كما في الشكل ولكن بشكل تلقائي بمجرد إدخال البيانات في الشيت الأول les fiches وكل طبقة يلون لها المقطع الموافق لها بين النقطة الكلوميترية البداية والنهاية

وفي الأخير نحصل على الجدول الثاني أسفله

المرفق أسفله فيه شرح للمطلوب

وشكراجزيلا

synoptique.rar

[hassannahid05]

-للرفع-

هل هذا الكود يمكن تطويره

Sub colorer()
Dim i%, j%, k%, r%
Dim Xc, Xpk1%, Xpk2%, Xpks%

r = Sheets(2).Range("Pks").Row

For i = 7 To Range("B65535").End(xlUp).Offset(-1, 0).Row
Xc = Cells(i, 2).Value
Xpk1 = Cells(i, 6).Value
Xpk2 = Cells(i, 7).Value

    With Sheets(2)
    For j = 1 To .Range("B65535").End(xlUp).Row
    If .Cells(j, 2).Value = Xc Then

        For k = 1 To .Cells(r, 255).End(xlToLeft).Column
        Xpks = .Cells(r, k).Value
        Select Case Xpks
        Case Xpk1 To Xpk2
        .Cells(j, k).Interior.ColorIndex = 45
        End Select
        Next k

    End If
    Next j
    End With

Next i

End Sub

تم تعديل يوليو 19, 2009 بواسطه hassannahid05

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

السلام عليكم

تم التعديل على الكود

Sub kh_ColorIndex()
Dim MySheet_1 As Worksheet
Dim MySheet_2 As Worksheet
Dim I As Integer, J As Integer, K As Integer, R As Integer
Dim Xpk1 As Integer, Xpk2 As Integer, Xpks As Integer
Dim Xc
'==========================
Set MySheet_1 = ورقة1
Set MySheet_2 = ورقة2
R = MySheet_2.Range("A33").Row
'==========================
Application.ScreenUpdating = False
kh_Color_None
'==========================
For I = 11 To MySheet_1.Range("B65535").End(xlUp).Row
    '----------------
    With MySheet_1
        Xc = .Cells(I, 2).Value
        Xpk1 = .Cells(I, 6).Value
        Xpk2 = .Cells(I, 7).Value
    End With
    '----------------
    With MySheet_2
        For J = 7 To 29
            If .Cells(J, 1).Value = Xc Then
                For K = 2 To 92
                    Xpks = .Cells(R, K).Value
                    Select Case Xpks
                        Case Xpk1 To Xpk2
                        .Cells(J, K).Interior.ColorIndex = 45
                    End Select
                Next K
            End If
        Next J
    End With
    '-----------------
Next I
'==========================
Application.ScreenUpdating = True
End Sub

تفضل المرفق

synoptique_1.rar

[خالد القدس]

السلام عليكم

ما شاء الله استاذ خبور تجمع بين الحسنيين ( المعادلات والأكواد )

(( ولا ينبئك مثل خبير ))

زادك الله علماً وبركة ورزقا

[رفيق محمد]

بسم الله ما شاء الله

انا كنت عمال افكر فيها من ناحية التنسيق الشرطي لكن مشاركة اخي خبور خير اكثر من رائعة

زادك الله علما ورفعة

[Ahmed Emannan]

تحياتي اخي خبور

[aymanbadr90]

ما شاء الله

عبقر استاذنا

الحمد لله سوف نتعلم

[hassannahid05]

السلام عليكم

الله أكبر ،،، ما شاء الله

هذا هو المطلوب بعينه

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

هل تستطيع أن تزيد من عدد الطبقات أو بالأحرى تجعلها تلقائية بحيث إظا كانت 5طبقات تمسح باقي الطبقات وإذا كانت 40 طبقة تزداد طبقتين وهكذا

وهذا الملف المرفق فيه التعديلات التي أريدها أرجوا أن لا أكون ثقيلا عليك أخي الكريم

Sub kh_Color_None()
Dim MyRange As Range
Set MyRange = æÑÞÉ2.Range("B7:AP29,AZ7:CN29")
    MyRange.Interior.ColorIndex = xlNone
End Sub

لك شكري وامتناني وأعجابي أستاذي خبور

زادك الله رفعة وعلماً ونورا

synoptique2.rar

[hassannahid05]

-للرفع-

تحياتي

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

السلام عليكم

تم التعديل عدد الطبقات 100 كحد اعلى

عدد الاعمدة 255 كل الاعمدة ابتداءا من الثاني

ويمكنك تحديد عدد الاعمدة التي تريد استخدامها في الخلية A111

يتم اظهار الصفوف والاعمدة المستخدمة فقط

تفضل المرفق

synoptique2.rar

[hassannahid05]

لا أعرف ماذا أقول أنت والله عبقري الله يعطيك الصحة

لك شكري وامتناني وأعجابي أستاذي خبور

زادك الله رفعة وعلماً ونورا ودمت لهذا المنتدى الغالي

[علي سالم 75]

مشكورررررررررررررر

[hassannahid05]

السلام عليكم إخواني الكرام

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

هل تستطيع أن تعمل ماكرو يجعل ما في خانة "المصداقية" يكتب تلقائيا في المكان الملون بين النقطتين الكيلومتريتين أي كل طبقة لها مصداقية validation ok أو validation non تكتب أو يصير لها لينك في شيت les fichiers كما في المثال الماثل أمامكم ولكن بشكل أوتوماتيكي في جميع الخانات الملونة

ولكم جزيل الشكر

synoptique final1.rar