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

Question

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

在下面的 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

结束子

Answer 1

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

您已经添加了创建我在 cmets 中谈到的表格的代码

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

事实上，它甚至更简单......这是最终答案！ :-) -->

---

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