sortare coloana in functie de culoarea TEXTULUI

[Bogdan]

salutare ,
Am o mare problema am nevoie de un MACRO care sa ma ajute sa fac o sortare ( ascendenta sau descendenta ) pe o coloana in functie de culoarea TEXTULUI ( FONT COLOR ) .

eu am urmatorul macro care din pacate ma ajuta sa sortez datele in functie de culoarea celulei

Cod: Selectaţi tot

Sub SortByColor()
    On Error GoTo SortByColor_Err

    Dim sRangeAddress As String
    Dim sStartCell As String
    Dim sEndCell As String
    Dim rngSort As Range
    Dim rng As Range

    Application.ScreenUpdating = False

    sStartCell = InputBox("Enter the cell address of the " & _
      "top cell in the range to be sorted by color" & _
      Chr(13) & "i.e.  'A1'", "Enter Cell Address")

    If sStartCell > "" Then
        sEndCell = Range(sStartCell).End(xlDown).Address
        Range(sStartCell).EntireColumn.Insert
        Set rngSort = Range(sStartCell, sEndCell)
        For Each rng In rngSort
            rng.Value = rng.Offset(0, 1).Interior.ColorIndex
        Next
        Range(sStartCell).Sort Key1:=Range(sStartCell), _
          Order1:=xlAscending, Header:=xlNo, _
          Orientation:=xlTopToBottom
        Range(sStartCell).EntireColumn.Delete
    End If

SortByColor_Exit:
    Application.ScreenUpdating = True
    Set rngSort = Nothing
    Exit Sub

SortByColor_Err:
    MsgBox Err.Number & ": " & Err.Description, _
      vbOKOnly, "SortByColor"
    Resume SortByColor_Exit
End Sub

multumesc anticipat

[Dr. Cloud]

In codul tau trebuie sa faci din :

Cod: Selectaţi tot

rng.Value = rng.Offset(0, 1).Interior.ColorIndex

in

Cod: Selectaţi tot

rng.Value = rng.Offset(0, 1).Font.ColorIndex

Sortare ascendenta:

Cod: Selectaţi tot

Sub SortByColorAscending()
On Error GoTo SortByColor_Err

Dim sRangeAddress As String
Dim sStartCell As String
Dim sEndCell As String
Dim rngSort As Range
Dim rng As Range

Application.ScreenUpdating = False

sStartCell = InputBox("Enter the cell address of the " & _
"top cell in the range to be sorted by color" & _
Chr(13) & "i.e. 'A1'", "Enter Cell Address")

    If sStartCell > "" Then
         sEndCell = Range(sStartCell).End(xlDown).Address
                  Range(sStartCell).EntireColumn.Insert
            Set rngSort = Range(sStartCell, sEndCell)
         For Each rng In rngSort
           rng.Value = rng.Offset(0, 1).Font.ColorIndex
          
         Next
             Range(sStartCell).Sort Key1:=Range(sStartCell), _
                 Order1:=xlAscending, Header:=xlNo, _
               Orientation:=xlTopToBottom
             Range(sStartCell).EntireColumn.Delete
    End If

SortByColor_Exit:
    Application.ScreenUpdating = True
        Set rngSort = Nothing
Exit Sub

SortByColor_Err:
    MsgBox Err.Number & ": " & Err.Description, _
        vbOKOnly, "SortByColor"
    Resume SortByColor_Exit
End Sub

Si urmatorul cod este pentru o sortare descendenta:

Cod: Selectaţi tot

Sub SortByColorDescending()
On Error GoTo SortByColor_Err

Dim sRangeAddress As String
Dim sStartCell As String
Dim sEndCell As String
Dim rngSort As Range
Dim rng As Range

Application.ScreenUpdating = False

sStartCell = InputBox("Enter the cell address of the " & _
"top cell in the range to be sorted by color" & _
Chr(13) & "i.e. 'A1'", "Enter Cell Address")

    If sStartCell > "" Then
         sEndCell = Range(sStartCell).End(xlDown).Address
                  Range(sStartCell).EntireColumn.Insert
            Set rngSort = Range(sStartCell, sEndCell)
         For Each rng In rngSort
           rng.Value = rng.Offset(0, 1).Font.ColorIndex
          
         Next
             Range(sStartCell).Sort Key1:=Range(sStartCell), _
                 Order1:=xlDescending, Header:=xlNo, _
               Orientation:=xlTopToBottom
             Range(sStartCell).EntireColumn.Delete
    End If

SortByColor_Exit:
    Application.ScreenUpdating = True
        Set rngSort = Nothing
Exit Sub

SortByColor_Err:
    MsgBox Err.Number & ": " & Err.Description, _
        vbOKOnly, "SortByColor"
    Resume SortByColor_Exit
End Sub

[Bogdan]

Salutare ,
Alex iti multumesc mult de tot !!!
merge perfect !