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

الردود الموصى بها

قام بنشر

مرفق ملف به عدد 2 ماكرو

الاول يسألك عن رقم اللون ، ثم يختار الخلايا التي بها اللون المناظر

و الثاني

يعرض لك الالوان و ارقامها بدءا من الخلية الفعالة

Sub Find_By_foramt()



reask:

On Error GoTo errnumb

Dim x As Byte

x = InputBox("Enter the Color index", "enter color index", 4)


errnumb:

If Err.Number = 13 Then

 MsgBox "Type Mismatch,  choose a number between 0 and 56"

End If

'MsgBox Str(Err.Number) + " : " + Err.Description


If IsNull(x) Or x > 56 Or Not IsNumeric(x) Then

 MsgBox " choose a number between 0 and 56"

 GoTo reask

' Exit Sub

End If


Dim Myrow As Long, MyCol As Long

Myrow = Selection.Rows.Count

MyCol = Selection.Columns.Count

Mycells = Selection.Cells.Count

Dim MyMatrix() As String, Myind As Long

'Dim myMultipleRange As Range, Mytemp As Range

ReDim MyMatrix(Mycells)


' to overcome ubsidedown selection

'Dim myr As Range

'myr = ActiveSheet.Selection

Selection.Cells(1, 1).Select

Selection.Cells(1, 1).Activate

'myr.Select



Myind = 0


For i = 0 To Myrow - 1

 For j = 0 To MyCol - 1

    If ActiveCell.Offset(i, j).Interior.ColorIndex = x Then

     Myind = Myind + 1

     MyMatrix(Myind) = ActiveCell.Offset(i, j).Address

    End If

  Next j

Next i

If Myind = 0 Then Exit Sub


Dim mm As String

mm = MyMatrix(1) & ","

For i = 2 To Myind - 1

  mm = mm & MyMatrix(i) & ","

Next

If Myind > 0 Then mm = mm + MyMatrix(Myind) + ""

Range(mm).Select


End Sub






Sub Listcolors()

ActiveCell.Offset(0, 0).Value = "ColorIndex"

ActiveCell.Offset(0, 1).Value = "Color"


For i = 1 To 56 ' Selection.Cells.Count

   ActiveCell.Offset(i, 0).Value = i

   ActiveCell.Offset(i, 1).Interior.ColorIndex = i

Next i

    

End Sub

SelectByCellColor.rar

  • Thanks 1

انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد

يجب ان تكون عضوا لدينا لتتمكن من التعليق

انشئ حساب جديد

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

سجل حساب جديد

تسجيل دخول

هل تمتلك حساب بالفعل ؟ سجل دخولك من هنا.

سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information