sortare coloana in functie de culoarea TEXTULUI

sortare coloana in functie de culoarea TEXTULUI

Mesajde Bogdan » Mie Noi 18, 2009 4:35 pm

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
Ultima oară modificat de Anonymous pe Mie Noi 18, 2009 5:29 pm, modificat 1 dată în total.
Motiv: Adaugare tag-uri pentru cod
Bogdan
 
Mesaje: 27
Membru din: Mar Oct 20, 2009 11:10 am

Re: sortare coloana in functie de culoarea TEXTULUI

Mesajde Dr. Cloud » Mie Noi 18, 2009 5:29 pm

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
Dr. Cloud
 
Mesaje: 3329
Membru din: Mar Oct 02, 2012 11:19 am

Re: sortare coloana in functie de culoarea TEXTULUI

Mesajde Bogdan » Mie Noi 18, 2009 5:41 pm

Salutare ,
Alex iti multumesc mult de tot !!!
merge perfect !
Bogdan
 
Mesaje: 27
Membru din: Mar Oct 20, 2009 11:10 am


Înapoi la Visual Basic for Application (VBA) cu Excel - Intrebari tehnice

Cine este conectat

Utilizatorii ce navighează pe acest forum: Niciun utilizator înregistrat şi 4 vizitatori