إخفاء صفوف فارغة بشرط

[عبدالعزيز محمد]

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

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

استخدم أوفيس 2010 .

كشف عام مرتبات.rar

[ياسر خليل أبو البراء]

أخي العزيز عزيز 60 (يا ريت الـ 60 تبقا لقب مش رقم)

بالنسبة لطلبك رغم إنه يبدو سهل إلا إنه غير مفهوم

للتأكيد فقط .. هل تريد إخفاء الصف في حالة وجود النص "منتقل" في العمود AR ..أقصد شرط الإخفاء هو أن يكون الصف فارغ ..أم أنه يحتوي على كلمة منتقل ؟؟

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

[عبدالعزيز محمد]

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

بارك الله فيكم

شرط إخفاء الصف -أو الصفوف- في العمود AR هو نص-منتقل-

[عبدالعزيز محمد]

مازلت انتظرالرد من الأخوة..............

[سليم حاصبيا]

اكتب هذا الكود و عين له زر على الصفحة

انه يقوم بأخفاء الصفوف المطلوبة و بكبسة ثانية يعيدها الى الظهور

Sub hid_text()
Range("ar7:ar98").SpecialCells(2).EntireRow.Hidden = Not (Range("ar7:ar98").SpecialCells(2).EntireRow.Hidden)
End Sub

 

[ياسر خليل أبو البراء]

تسلم أخي الحبيب سليم على الإبداعات المتميزة

بارك الله لنا فيك ولا حرمنا منك أبداً

تقبل تحياتي

[عادل حنفي]

كود جميل اخي سليم  سلمت يداك

وهذه بطريقة اخري مع تغيير اسم الزر

تحياتي

 

كشف عام مرتبات.rar

[عبدالعزيز محمد]

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

جزاكم الله خيراً

كود جميل أخي عادل ولكنه طويل ولم افهمه ولم أجد رقم العمود الذي به شرط الإخفاء-AR- لو بالإمكان معرفة رقم العمود -الذي يوضع به شرط الإخفاء-حتى يمكن الاستفادة منه في أعمدة أخرى بها شرط محدد .

 

[ياسر خليل أبو البراء]

رقم العمود AR هو الرقم 44 في الكود ..

[عبدالعزيز محمد]

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

جزاكم الله خيراً وأسعد أوقاتكم.

وكما يقال الحلو مايكملش أود معروفاً آخر وهو تلوين تسمية الزر مرة بالأحمر عند الإخفاء وعند الإظهار باللون الأزرق .

تم تعديل أكتوبر 18, 2015 بواسطه عزيز 60

[سليم حاصبيا]

يجب تعديل النطاق الى الذي تريده 

range("ar7:ar98")

و كذلك ادراج الاسم الصحيح الزر  Bitton 1

 

انظر الى المرفق (الملف الاول)

,

 

Sub Change_Color_Bot_Text()
 If Range("a1:a8").SpecialCells(2).EntireRow.Hidden = False Then
ActiveSheet.Shapes.Range(Array("Button 1")).Select
    Selection.Characters.Text = "اخفاء"
    With Selection.Characters(Start:=1, Length:=5).Font
        .Name = "Traditional Arabic"
        .Size = 25
        .Bold = True
        .ColorIndex = 3
    End With
    
    ''''''''''''''''''''''''''''''''''''''''''''''''
    Else
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    Selection.Characters.Text = "إطهار"
    With Selection.Characters(Start:=1, Length:=5).Font
        .Name = "Traditional Arabic"
        .Size = 25
        .Bold = True
        .ColorIndex = 5
    End With
    
'''''''''''''''''''''''''''''''''''''''''''''''''''
    
  End If
  Range("a1:a8").SpecialCells(2).EntireRow.Hidden = Not (Range("a1:a8").SpecialCells(2).EntireRow.Hidden)
    
End Sub

 

change_color_button.zip

every 3 cells in sheet salim advanced.zip

تم تعديل أكتوبر 18, 2015 بواسطه سليم حاصبيا

[ياسر خليل أبو البراء]

أخي الكريم عزيز 6000 (يا ريت اللقب بدلاً من الرقم 600 عشان دايماً بشوف الرقم 6)

إليك الملف المرفق التالي فيه تعديل بسيط للكود

مع استبدال زر Form Button بآخر ActiveX Button حيث أن الأول لا يدعم تلوين الخلفية

إليك الكود المستخدم

Private Sub CommandButton1_Click()
    Dim I As Long, N As Long, M As String, XX As Shape
    M = "منتقل"
    N = 0
    
    Application.ScreenUpdating = False
        With CommandButton1
            If .Caption = "إخفاء منتقل" Then
                For I = 7 To 98
                    If Cells(I, 44) = M Then
                        If Cells(I, 44).EntireRow.Hidden = False Then
                            Cells(I, 44).EntireRow.Hidden = True
                            N = N + 1
                        End If
                    End If
                    If N > 0 Then
                        .BackColor = vbBlue
                        .Caption = "إظهار منتقل"
                    End If
                Next I
            ElseIf .Caption = "إظهار منتقل" Then
                For I = 7 To 98
                    If Cells(I, 44) = M Then
                        If Cells(I, 44).EntireRow.Hidden = True Then
                            Cells(I, 44).EntireRow.Hidden = False
                            N = N + 1
                        End If
                    End If
                    If N > 0 Then
                        .BackColor = vbRed
                        .Caption = "إخفاء منتقل"
                    End If
                Next I
            End If
        End With
    Application.ScreenUpdating = True
End Sub

تقبل تحياتي

كشف عام مرتبات.rar

[سليم حاصبيا]

اخي ياسر

ما زال الملف القديم يرفق مع كل شيء ارفعه 

ولا يستنحيب لامر الحذف

انظر الى مشاركتي حول عذا الموضوع

ترى ملفين الاول هو المطلوب اما الثاني فقد رفض ان يحذف

[عبدالعزيز محمد]

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

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

فالزيادة المطلوبة على الكود السابق هو تلوين تسمية الزر في كل مرة بلون مختلف.

[ياسر خليل أبو البراء]

وهذا كود آخر .. اثراءً للموضوع

Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
        With CommandButton1
            If .Caption = "إخفاء منتقل" Then
                HideAll
                .BackColor = vbBlue
                .Caption = "إظهار منتقل"
            ElseIf .Caption = "إظهار منتقل" Then
                ShowAll
                .BackColor = vbRed
                .Caption = "إخفاء منتقل"
            End If
        End With
    Application.ScreenUpdating = True
End Sub

Sub ShowAll()
    On Error Resume Next
    Application.ScreenUpdating = False
        With ActiveSheet.Cells
            .EntireRow.Hidden = False
        End With
    Application.ScreenUpdating = True
End Sub

Sub HideAll()
    Dim RW As Range, R_TB As Range
    
    Application.ScreenUpdating = False
    For Each RW In Range("AR7:AR98")
        If RW.Value = "منتقل" Then
            If R_TB Is Nothing Then
                Set R_TB = RW
            Else
                Set R_TB = Union(R_TB, RW)
            End If
        End If
    Next RW
    R_TB.EntireRow.Hidden = True
    Application.ScreenUpdating = True
End Sub

 

[عبدالعزيز محمد]

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

[ياسر خليل أبو البراء]

غير بقا رقم 60 دا للقب الجميل الخاص بك

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