0

我想在每行背景颜色的六个单元格（现实生活中的商店）中输入，从绿色到红色排序较高。

在 excel 2010 中就像照片但在 2003 版本中无法正常工作......我如何在 excel 2003 中做到这一点？照片http://img32.imageshack.us/img32/4909/srv20130328113621.png

在 excel 2010 中，我使用此代码并且工作完美

If Application.Version >= "12.0" Then
    For counter = 3 To 103
        Range("I" & counter & ",K" & counter & ",M" & counter & ",O" & counter & ",Q" & counter & ",S" & counter).Select
        Selection.FormatConditions.AddColorScale ColorScaleType:=3
        Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
        Selection.FormatConditions(1).ColorScaleCriteria(1).Type = _
        xlConditionValueLowestValue
    With Selection.FormatConditions(1).ColorScaleCriteria(1).FormatColor
        .Color = 7039480
    End If
    End With
        Selection.FormatConditions(1).ColorScaleCriteria(2).Type = _
        xlConditionValuePercentile
        Selection.FormatConditions(1).ColorScaleCriteria(2).Value = 50
    With Selection.FormatConditions(1).ColorScaleCriteria(2).FormatColor
        .Color = 8711167
    End If
    End With
        Selection.FormatConditions(1).ColorScaleCriteria(3).Type = _
        xlConditionValueHighestValue
    With Selection.FormatConditions(1).ColorScaleCriteria(3).FormatColor
        .Color = 8109667
    End If
    End With
    Next counter
Else
End If

对不起，我的英语不好。

4

1 回答 1

0

行 ！！使用此代码完美运行！

在第一个子 xromata（希腊语中的颜色）中，我有一些用于不同工作表的设置。在此之后调用 sortarisma 并参考第一列与第二列和行数不同！

Sub Xromata(a As Integer)
    If a = 1 Then
        Call Sortarisma(11, 3, 103)
        ElseIf a = 2 Then
        Call Sortarisma(12, 3, 111)
        ElseIf a = 3 Then
        Call Sortarisma(9, 2, 103)
        ElseIf a = 4 Then
        Call Sortarisma(10, 2, 111)
        ElseIf a = 5 Then
        Call Sortarisma(11, 4, 103)
        Call Sortarisma(12, 4, 103)
        ElseIf a = 6 Then
        Call Sortarisma(12, 4, 111)
        Call Sortarisma(13, 4, 111)
    Else
End If

End Sub
Sub Sortarisma(arxi As Integer, per As Integer, numofrows As Integer)

Dim Arr(1 To 6) As Single
Dim i As Integer
Dim l As Integer
Dim k As Integer
Dim j As Integer
Dim ff As Integer
Dim ll As Integer
Dim temp As Single
ff = 1
ll = 6

For i = 3 To numofrows
    temp = 0
    Arr(1) = Cells(i, arxi)
    Arr(2) = Cells(i, arxi + per)
    Arr(3) = Cells(i, arxi + (per * 2))
    Arr(4) = Cells(i, arxi + (per * 3))
    Arr(5) = Cells(i, arxi + (per * 4))
    Arr(6) = Cells(i, arxi + (per * 5))

    For k = ff To ll - 1
        For j = k + 1 To ll
            If Arr(k) > Arr(j) Then
            temp = Arr(j)
            Arr(j) = Arr(k)
            Arr(k) = temp
            End If
        Next j
    Next k
    ''''''''''''''''''''
    For l = arxi To arxi + (per * 5) Step per
        If Cells(i, l) = Arr(1) And Cells(i, l) >= 0 Then
            Call xromatismos_keliou(i, l, 6)
        ElseIf Cells(i, l) = Arr(2) And Cells(i, l) >= 0 Then
            Call xromatismos_keliou(i, l, 5)
        ElseIf Cells(i, l) = Arr(3) And Cells(i, l) >= 0 Then
            Call xromatismos_keliou(i, l, 4)
        ElseIf Cells(i, l) = Arr(4) And Cells(i, l) >= 0 Then
            Call xromatismos_keliou(i, l, 3)
        ElseIf Cells(i, l) = Arr(5) And Cells(i, l) >= 0 Then
            Call xromatismos_keliou(i, l, 2)
        ElseIf Cells(i, l) = Arr(6) And Cells(i, l) >= 0 Then
            Call xromatismos_keliou(i, l, 1)
        ElseIf Cells(i, l) = Arr(1) And Cells(i, l) < 0 Then
            Call xromatismos_keliou(i, l, 6)
        ElseIf Cells(i, l) = Arr(2) And Cells(i, l) < 0 Then
            Call xromatismos_keliou(i, l, 5)
        ElseIf Cells(i, l) = Arr(3) And Cells(i, l) < 0 Then
            Call xromatismos_keliou(i, l, 4)
        ElseIf Cells(i, l) = Arr(4) And Cells(i, l) < 0 Then
            Call xromatismos_keliou(i, l, 3)
        ElseIf Cells(i, l) = Arr(5) And Cells(i, l) < 0 Then
            Call xromatismos_keliou(i, l, 2)
        ElseIf Cells(i, l) = Arr(6) And Cells(i, l) < 0 Then
            Call xromatismos_keliou(i, l, 1)
        End If
    Next l
    Next i
Call addindex(numofrows + 2)
Application.Goto Reference:=Range("a1"), Scroll:=True
End Sub
Sub xromatismos_keliou(row As Integer, col As Integer, bathmos As Integer)

If bathmos = 1 Then
    Cells(row, col).Interior.ColorIndex = 10
    ElseIf bathmos = 2 Then
    Cells(row, col).Interior.ColorIndex = 50
    ElseIf bathmos = 3 Then
    Cells(row, col).Interior.ColorIndex = 43
    ElseIf bathmos = 4 Then
    Cells(row, col).Interior.ColorIndex = 44
    ElseIf bathmos = 5 Then
    Cells(row, col).Interior.ColorIndex = 45
    ElseIf bathmos = 6 Then
    Cells(row, col).Interior.ColorIndex = 46
    Cells(row, col).Select
    With Selection.Font
    .Bold = True
    End With

    Else
End If

End Sub
Sub addindex(thesi As Integer)

Cells(thesi, 1).Interior.ColorIndex = 10
Cells(thesi, 1).Value = "1"
Cells(thesi, 2).Interior.ColorIndex = 50
Cells(thesi, 2).Value = "2"
Cells(thesi, 3).Interior.ColorIndex = 43
Cells(thesi, 3).Value = "3"
Cells(thesi, 4).Interior.ColorIndex = 44
Cells(thesi, 4).Value = "4"
Cells(thesi, 5).Interior.ColorIndex = 45
Cells(thesi, 5).Value = "5"
Cells(thesi, 6).Interior.ColorIndex = 46
Cells(thesi, 6).Value = "6"

End Sub
于 2013-03-30T08:31:55.430 回答