ترتيب حسب الالوان

[Alttear]

السلام عليكم

كيف اقوم بترتيب الخلايا حسب الالوان
الاعمدة التي تحوي على خلايا بيضاء اولا ثم الملونة ؟

Sort Colored Cell.rar

[ياسر خليل أبو البراء]

وعليكم السلام

جرب الكود التالي

Sub SortColumnsByColorCount()
    Dim arr()       As Variant
    Dim iCol        As Long
    Dim firstRow    As Long
    Dim lastRow     As Long
    Dim i           As Long
    Dim x           As Long

    Application.ScreenUpdating = False
        firstRow = 3
        lastRow = Range("B" & firstRow).CurrentRegion.Rows.Count + firstRow - 1
    
        For iCol = 2 To 6
            ReDim Preserve arr(iCol - 2)
            arr(UBound(arr)) = Val(ColorFunction(Range(Cells(3, iCol), Cells(lastRow, iCol))) & "." & iCol)
        Next iCol
    
        Call BubbleSort(arr())
        
        For i = LBound(arr) To UBound(arr)
            x = Val(Split(CStr(arr(i)), ".")(1))
            Range(Cells(3, x), Cells(lastRow, x)).Copy Cells(3, iCol + 2)
            iCol = iCol + 1
        Next i
    Application.ScreenUpdating = True
End Sub

Function ColorFunction(rRange As Range)
    Dim rCell       As Range
    Dim vResult     As Long

    For Each rCell In rRange
        If rCell.Interior.ColorIndex <> -4142 Then
            vResult = vResult + 1
        End If
    Next rCell

    ColorFunction = vResult
End Function

Sub BubbleSort(list())
    Dim first       As Long
    Dim last        As Long
    Dim i           As Long
    Dim j           As Long
    Dim temp        As Double

    first = LBound(list)
    last = UBound(list)
    
    For i = first To last - 1
        For j = i + 1 To last
            If list(i) > list(j) Then
                temp = list(j)
                list(j) = list(i)
                list(i) = temp
            End If
        Next j
    Next i
End Sub

 

[Alttear]

ما شاء الله .. دائما في قمة الابداع استاذ ياسر
وضعت النتيجة لاشرح المطلوب و ليس لاجل اجراء عملية النسخ حاولت ازالت عملية النسخ و تبديلها بعملية الترتيب فقط و لم استطع 
اما كتعديل للملف فارجو جعل iCol يبدأ بعد أول عمود فارغ وينتهي بأخر قيمة 
قرأت قليلا و اظن انها تتم بهذا الشكل 
AfterFirstEmpty  = ?
LastCol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
For iCol = AfterFirstEmpty To LastCol

و جزاك الله كل خير

[ياسر خليل أبو البراء]

يمكن نسخ النتائج ووضعها في مكان البيانات الأصلية بسطر آخر يقوم بعملية النسخ ثم حذف الصفوف المساعدة

[Alttear]

تمام استاذي .. و لكن الا يمكن الغاء عملية النسخ ؟
بعض الملفات لدي تحوي على عدد كبير من الاعمدة و نسخها يتطلب وقتا

[ياسر خليل أبو البراء]

جرب الكود التالي
 

Sub SortColumnsByColorCount()
    Dim iCol        As Long
    Dim firstRow    As Long
    Dim lastRow     As Long
    Dim i           As Long
    Dim x           As Long

    Application.ScreenUpdating = False
        firstRow = 3
        lastRow = Range("B" & firstRow).CurrentRegion.Rows.Count + firstRow - 1
    
        For iCol = 2 To 6
            Cells(lastRow + 1, iCol).Value = ColorFunction(Range(Cells(3, iCol), Cells(lastRow, iCol)))
        Next iCol
    
        Range("B" & firstRow & ":F" & lastRow + 1).Sort Key1:=Range("B" & lastRow + 1), Header:=xlNo, Orientation:=xlLeftToRight
        Range("B" & lastRow + 1 & ":F" & lastRow + 1).ClearContents
    Application.ScreenUpdating = True
End Sub

Function ColorFunction(rRange As Range)
    Dim rCell       As Range
    Dim vResult     As Long

    For Each rCell In rRange
        If rCell.Interior.ColorIndex <> -4142 Then
            vResult = vResult + 1
        End If
    Next rCell

    ColorFunction = vResult
End Function

 

[Alttear]

السلام عليكم
جزاك الله خيرا استاذ ياسر هذا هو المطلوب 
وقد قمت بتعديله ليلبي احتياجاتي بشكل اكبر فما رأيك

Sub SortColumnsByColorCount()
    Dim iCol        As Long
    Dim firstRow    As Long
    Dim firstcol     As Long
    Dim lastRow     As Long
    Dim LastCol     As Long
    Dim i           As Long
    Dim x           As Long

    Application.ScreenUpdating = False
        firstRow = 1
        firstcol = 1
        lastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row + firstRow - 1
        LastCol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
        
    
        For iCol = 1 To LastCol
            Cells(1, iCol).Value = ColorFunction(Range(Cells(1, iCol), Cells(lastRow, iCol)))
        Next iCol
    
        Range(Cells(firstRow, firstcol), Cells(lastRow, LastCol)).Sort Key1:=Range("A" & 1), Header:=xlNo, Orientation:=xlLeftToRight
        Range(Cells(firstRow, firstcol), Cells(firstRow, LastCol)).ClearContents
    
    Application.ScreenUpdating = True
End Sub

Function ColorFunction(rRange As Range)
    Dim rCell       As Range
    Dim vResult     As Long

    For Each rCell In rRange
        If rCell.Interior.ColorIndex <> -4142 Then
            vResult = vResult + 1
        End If
    Next rCell

    ColorFunction = vResult
End Function

 

[ياسر خليل أبو البراء]

وجزيت خيراً بمثل ما دعوت لي أخي الكريم

والحمد لله أن تم المطلوب على خير .. وأي كود قابل للتعديل والتطويع بما يتناسب مع الملف الأصلي بشرط فهم الكود وفهم كيفية التعديل عليه

تقبل تحياتي