إختيار مجموعة خلايا عن طريق لون خلفيتها

[محمد طاهر عرفه]

مرفق ملف به عدد 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