Question

我有一个VBA代码，其中选择了0到13的数字（固定），从这里将为地图提供相应的颜色。但是......我希望将其改为每种颜色的范围。例如，我不希望“1”耦合到深蓝色，“2”耦合到浅蓝色等，但我想要一个范围。喜欢：0到50之间的数字 - ＆gt;深蓝色，50 - 100 - ＆gt;淡蓝色等。

在下面的VBA代码中，您可以看到高于13的数字（intStateValue）与另一个协议一起提供。但是代码中没有范围（For intState = 1 to rngStates.Rows.Count）。如何创建如上所述的范围（0 - 50,50-100,100 - 150等）？

希望有人能帮助我这个！在此先感谢!!

Option Explicit

Sub Kleurgemeenten()
'
' Using the values from named range POSTCODEGEBIEDEN
' And the colours from named range KLEUREN
' re colour the map on sheet MainMap
'
Dim intState As Integer
Dim strStateName As String
Dim intStateValue As Integer
Dim intColourLookup As Integer
Dim rngStates As Range
Dim rngColours As Range

Set rngStates = Range(ThisWorkbook.Names("GEMEENTE").RefersTo)
Set rngColours = Range(ThisWorkbook.Names("KLEUREN").RefersTo)

    With Worksheets("MainMap")
    For intState = 1 To rngStates.Rows.Count
        strStateName = rngStates.Cells(intState, 1).Text
        intStateValue = rngStates.Cells(intState, 2).Value
        If intStateValue > 13 Then
            ' stripped
            With .Shapes(strStateName)
                intColourLookup = Application.WorksheetFunction.Match(CInt(Left(CStr(intStateValue), 1)), Range("KLEUREN"), True)
                .Fill.Patterned msoPatternWideUpwardDiagonal
                .Fill.ForeColor.RGB = rngColours.Cells(intColourLookup, 1).Offset(0, 1).Interior.Color
                intColourLookup = Application.WorksheetFunction.Match(CInt(Right(CStr(intStateValue), 1)), Range("KLEUREN"), True)
                .Fill.BackColor.RGB = rngColours.Cells(intColourLookup, 1).Offset(0, 1).Interior.Color
            End With
        Else
            ' single colour
            intColourLookup = Application.WorksheetFunction.Match(intStateValue, Range("KLEUREN"), True)
            With .Shapes(strStateName)
                .Fill.Solid
                .Fill.ForeColor.RGB = rngColours.Cells(intColourLookup, 1).Offset(0, 1).Interior.Color
            End With
        End If
    Next
End With

End Sub

Answer 1

我不确定我是否正确理解您的问题，但我认为这可能会对您有所帮助。

您已在评论中添加了创建我所谈论的表格的代码

Option Explicit

Sub Kleurgemeenten()
'
' Using the values from named range POSTCODEGEBIEDEN
' And the colours from named range KLEUREN
' re colour the map on sheet MainMap
'
Dim intState As Integer
Dim strStateName As String
Dim intStateValue As Integer
Dim intColourLookup As Integer
Dim rngStates As Range
Dim rngColours As Range

Set rngStates = Range(ThisWorkbook.Names("GEMEENTE").RefersTo)
Set rngColours = Range(ThisWorkbook.Names("KLEUREN").RefersTo)

Dim colorTable(1 To 2, 1 To 13) As Long
' creaing the table

With Worksheets("MainMap")
    For intState = 1 To rngStates.Rows.Count
        strStateName = rngStates.Cells(intState, 1).Text
        intStateValue = rngStates.Cells(intState, 2).Value

        Dim colorNumber As Long, i As Long
        colorNumber = 14

        For i = 1 To 13
            If intStateValue >= colorTable(1, i) And intStateValue < colorTable(2, i) Then colorNumber = i
        Next i

        If colorNumber > 13 Then
            ' stripped
            With .Shapes(strStateName)
                intColourLookup = Application.WorksheetFunction.Match(CInt(Left(CStr(colorNumber), 1)), Range("KLEUREN"), True)
                .Fill.Patterned msoPatternWideUpwardDiagonal
                .Fill.ForeColor.RGB = rngColours.Cells(intColourLookup, 1).Offset(0, 1).Interior.Color
                intColourLookup = Application.WorksheetFunction.Match(CInt(Right(CStr(colorNumber), 1)), Range("KLEUREN"), True)
                .Fill.BackColor.RGB = rngColours.Cells(intColourLookup, 1).Offset(0, 1).Interior.Color
            End With
        Else
            ' single colour
            intColourLookup = Application.WorksheetFunction.Match(colorNumber, Range("KLEUREN"), True)
            With .Shapes(strStateName)
                .Fill.Solid
                .Fill.ForeColor.RGB = rngColours.Cells(intColourLookup, 1).Offset(0, 1).Interior.Color
            End With
        End If
    Next
End With
End Sub

Answer 2

事实上，它甚至不那么复杂......这是最终答案！ :-) - ＆gt;

Option Explicit

Sub Kleurgemeenten()
'
' Using the values from named range POSTCODEGEBIEDEN
' And the colours from named range KLEUREN
' re colour the map on sheet MainMap
'
    Dim intState As Integer
    Dim strStateName As String
    Dim intStateValue As Long
    Dim intColourLookup As Integer
    Dim rngStates As Range
    Dim rngColours As Range
    Dim WS_Control As Worksheet
    Dim i As Long

    Set WS_Control = Worksheets("Control")

    Set rngStates = Range(ThisWorkbook.Names("GEMEENTE").RefersTo)
    Set rngColours = Range(ThisWorkbook.Names("KLEUREN").RefersTo)

    With Worksheets("MainMap")
        For intState = 1 To rngStates.Rows.Count
            strStateName = rngStates.Cells(intState, 1).Text
            intStateValue = rngStates.Cells(intState, 2).Value
            If intStateValue >= WS_Control.Range("E14").Value Then
                'if value is higher than last number of the defined range
                With .Shapes(strStateName)
                    .Fill.Solid
                    .Fill.ForeColor.RGB = WS_Control.Cells(14, 6).Interior.Color
                End With
            Else
                'if value is inside the defined range
                'Loop through value ranges
                For i = 3 To 14
                    'if relavent range found
                    If intStateValue < WS_Control.Range("E" & i).Value Then
                        intColourLookup = i - 2  'Had to reduce 2 because name range "rngColours" is defined from "E2"
                        Exit For
                    End If
                Next i

                With .Shapes(strStateName)
                    .Fill.Solid
                    .Fill.ForeColor.RGB = rngColours.Cells(intColourLookup, 1).Offset(0, 1).Interior.Color
                End With
            End If
        Next
    End With

End Sub

如何在VBA中将固定数字更改为范围

2 个答案: