求助，求老司机带路，求VBA代码实现颜色的多列在底端排序，谢谢！

心云德乐

1.求VBA代码实现颜色的多列在底端排序，
2.要求Sheet1工作表里的B2:AF42单元格区域按列与按颜色在底端排序，
3.现实中工作表不知道Sheet1总单元格区域有多少行与列，
4知道第1行与A列的数据是固定的，
5.”按颜色在底端排序效果图“工作表就是希望的结果。

多列颜色排序.rar (23.94 KB, 下载次数: 5)

2019-12-5 00:23 上传

点击文件名下载附件

心云德乐

为了不让帖潜下去。
学习VBA很长时间了，东拼西凑写了一堆代码，部分抄书本的代码，不合格的代码！！！运行不通！！！
请高手帮忙看看，错在哪里，谢谢！


Sub text2()                                                              '定义过程名称，程序开始
    Dim i&, j&, k&, t, r, g                                       '声明过程中需要的变量与数据类型
                                                    '获取第B列有效的行数，最后的非空单元格赋值给 r
    Set r = Cells(Rows.Count,"B").End(xlUp).Row
                                                     '获取第1行有效的列数，最后的非空单元格赋值给 g
    Set g = Cells(1, Columns.Count).End(xlToLeft).Column
    For k = 2 To g                                                     '设置循环列的初始值，终止值
        For i = 2 To r - 1                                         '设置循环行的初始值，终止值
            If Cells(i, k).Interior.Color <> xlNone Then         '如果第一个单元格不是xlNone空白色
                                               '设置循环行从同列的非第一个单元格开始的初始值，终止值
            For j = i + 1 To r
                If Cells(j, k).Interior.Color = xlNone Then   '如果非第一个单元格是xlNone空白色
                    t = Cells(j, k)                            '记住是空白色的单元格
                    Cells(j, k) = Cells(i, k)                '空白单元格交换红色的单元格
                    Cells(i, k) = t              '这一个的意思我也不了解，抄书上的，意思是交换
                End If                                   '结束If循环
            Next j                                     '结束For j循环
            End If                                   '结束If循环
        Next i                                     '结束For i循环
    Next k                                       '结束For k循环
End Sub                                        '结束

心云德乐

心云德乐

心云德乐 发表于 2019-12-8 22:54
为了不让帖潜下去。
学习VBA很长时间了，东拼西凑写了一堆代码，部分抄书本的代码，不合格的代码！！！运 ...

为了不让帖潜下去。
学习VBA很长时间了，东拼西凑写了一堆代码，部分抄书本的代码，不合格的代码！！！运行不通！！！
请高手帮忙看看，错在哪里，谢谢！


上面帖BUG已修改，求高手帮助，初学VBA，

xiangbaoan

Sub test() '录制宏修改
  Dim r As Long, c As Long, j As Long
  Application.ScreenUpdating = False
  With ActiveSheet
    With .Range("A1").CurrentRegion
      r = .Rows.Count
      c = .Columns.Count
    End With
    For j = c To 2 Step -1
      .Sort.SortFields.Clear
      .Sort.SortFields.Add2 Key:=.Cells(1, j), SortOn:=xlSortOnCellColor, Order:=xlAscending, DataOption:=xlSortNormal
      With .Sort
        .SetRange Range(Cells(1, j), Cells(r, j))
        .Header = xlYes
        .Apply
      End With
    Next
  End With
  Application.ScreenUpdating = True
End Sub