Изменения цветом на карте Украины в зависимости от значения таблицы Excel

ActiveSheet.Shapes(mstr).Select
        With Selection
            .ShapeRange.Fill.Transparency = 0.2
            .ShapeRange.Line.Weight = 0.75
            .ShapeRange.Line.DashStyle = msoLineSolid
            .ShapeRange.Line.Style = msoLineSingle
            .ShapeRange.Line.Transparency = 0#
            .ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
            .ShapeRange.Fill.Visible = msoTrue
            .ShapeRange.Fill.ForeColor.RGB = RGB(0, 0, 0)
            .ShapeRange.Fill.BackColor.RGB = RGB(255, 191, 0)
            .ShapeRange.Fill.PresetGradient msoGradientDiagonalUp, 3, _
                                                        msoGradientLateSunset
    End With

dim mArr1(), mArr2(),mArr3(), count1%,count2%,count3%
count1=0: count2=0: count3=0
with sheets("RegionsName")
   for i =2 to 28
      select case .cells(i,2).value
          case is <= 1250000
             count1=count1+1
             redim preserve mArr1(count1)
             marr1(count1)=i & ";" & trim(.cells(i,1).value ' Это фактически _
                   название соотверствующего Shape (~ "8;Запорізька обл.")
          case is > 1250000, is <= 1500000
             count2=count2+1
             redim preserve mArr2(count2)
             marr2(count2)=i & ";" & trim(.cells(i,1).value
          case is > 1500000
             count3=count3+1
             redim preserve mArr3(count3)
             marr3(count3)=i & ";" & trim(.cells(i,1).value 
      end select
   next 'i
end with

Sub WorkOnMap()
'Основний лістинг, що викликається _
        об'єктом START на аркуші "RegionsName"
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        If fun_SheetExists("Copy_МапаУкраїни") Then
            Sheets("Copy_МапаУкраїни").Delete
            Sheets("МапаУкраїни").Select
        End If
    Application.DisplayAlerts = True
    With Sheets("МапаУкраїни")
        .Copy Before:=Sheets("МапаУкраїни")
    End With
    With ActiveSheet
        .Name = "Copy_МапаУкраїни"
        .Tab.ColorIndex = 46
    End With
    Call NameSHP ' присвоєння назв
'Stop
    r = 2
    With Sheets("RegionsName")
        mArr = Range(.Cells(2, 1), _
        .Cells(.UsedRange.Row - 1 + .UsedRange.Rows.Count, 2)).Value
        mMAX = CLng(mArr(1, 2))
        For i = LBound(mArr, 1) To UBound(mArr, 1)
            If CLng(mArr(i, 2)) > mMAX Then
                mMAX = CLng(mArr(i, 2))
                r = i + 1
            End If
        Next 'i
    End With
Stop
    mstr = r & ";" & Application.Trim(mArr(r - 1, 1))
    Sheets("Copy_МапаУкраїни").Activate
    ActiveSheet.Shapes(mstr).Select
        With Selection
            .ShapeRange.Fill.Transparency = 0.2
            .ShapeRange.Line.Weight = 0.75
            .ShapeRange.Line.DashStyle = msoLineSolid
            .ShapeRange.Line.Style = msoLineSingle
            .ShapeRange.Line.Transparency = 0#
            .ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
            .ShapeRange.Fill.Visible = msoTrue
            .ShapeRange.Fill.ForeColor.RGB = RGB(0, 0, 0)
            .ShapeRange.Fill.BackColor.RGB = RGB(255, 191, 0)
            .ShapeRange.Fill.PresetGradient msoGradientDiagonalUp, 3, _
                                                        msoGradientLateSunset
    End With
    Cells(1, 1).Select
    Call mCategoriesColor '
    Cells(1, 1).Select
    MsgBox Space(12) & "DONE !"
    Application.ScreenUpdating = True
    Erase mArr
End Sub

Sub mCategoriesColor()
' крім максимуму, всі інші будуть забарвлені у відтінки сірого.
Dim CategorieA(), CategorieB(), CategorieC(), arrCateg()
Dim countA%, countB%, countC%
Dim b&
With Sheets("RegionsName")
    mArr = Range(.Cells(2, 1), .Cells(28, 2)).Value
End With
 
 countA = 0: countB = 0: countC = 0
' Stop
 For i = LBound(mArr, 1) To UBound(mArr, 1)
    Select Case CLng(mArr(i, 2))
        Case Is < 1250001
            countA = countA + 1
            ReDim Preserve CategorieA(countA)
            CategorieA(countA) = i + 1 & ";" & mArr(i, 1)
        Case 1250001 To 1500000
            countB = countB + 1
            ReDim Preserve CategorieB(countB)
            CategorieB(countB) = i + 1 & ";" & mArr(i, 1)
        Case 1500001 To mMAX - 1
            countC = countC + 1
            ReDim Preserve CategorieC(countC)
            CategorieC(countC) = i + 1 & ";" & mArr(i, 1)
    End Select
Next 'i
mstr = Join(CategorieA, Chr(34) & ", " & Chr(34))
Stop
Sheets("Copy_МапаУкраїни").Select
With ActiveSheet
    For i = 1 To 3
        Select Case i
            Case Is = 1
                .Shapes.Range(CategorieA).Select
                    With Selection
                        .ShapeRange.Fill.ForeColor.RGB = _
                                            RGB(234, 234, 234)
                    End With
            Case Is = 2
                .Shapes.Range(CategorieB).Select
                    With Selection
                        .ShapeRange.Fill.ForeColor.RGB = _
                                            RGB(192, 192, 192)
                    End With
            Case Is = 3 ' тут знаходитиметься max
                .Shapes.Range(CategorieC).Select
                    With Selection
                        .ShapeRange.Fill.ForeColor.RGB = _
                                            RGB(150, 150, 150)
                    End With
        End Select
    Next 'i
End With
End Sub