محمد طاهر عرفه قام بنشر يونيو 8, 2003 مشاركة قام بنشر يونيو 8, 2003 مرفق ملف به عدد 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 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.