VBA按红色字体排序到顶端

q8254733

1. Sub 宏1()
   
2. a = Sheet1.[a1048576].End(xlUp).Row
   
3. Sheet2.Range("A1:R31").Value = Sheet1.Range("A1:R31").Value
   
4. Sheet1.Range("A1:R31").Copy
   
5. Sheet2.Range("A1:R31").PasteSpecial
   
6. For c = 2 To a
   
7. d = 0
   
8.     For b = 3 To 18
   
9.         If Sheet1.Cells(c, b).Value <> "" Then
   
10.             If Sheet1.Cells(c, b).Font.Color = vbBLK Then
    
11.                 d = d - 20
    
12.             ElseIf Sheet1.Cells(c, b).Font.Color = vbRed Then
    
13.                 d = d + 1
    
14.             End If
    
15.         End If
    
16.         Sheet2.Cells(c, 19).Value = d
    
17.     Next b
    
18. Next c
    
19.     ActiveWorkbook.Worksheets("效果").Sort.SortFields.Clear
    
20.     ActiveWorkbook.Worksheets("效果").Sort.SortFields.Add2 Key:=Range("S2:S31"), _
    
21.         SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    
22. With ActiveWorkbook.Worksheets("效果").Sort
    
23.     .SetRange Range("A1:S31")
    
24.     .Header = xlYes
    
25.     .MatchCase = False
    
26.     .Orientation = xlTopToBottom
    
27.     .SortMethod = xlPinYin
    
28.     .Apply
    
29. End With
    
30. Columns("S:S").Delete Shift:=xlToLeft
    
31. End Sub
    

复制代码