Зараз обговорюють

"Тобто є ряд завдань, які взагалі без рекурсії не наважуються."  - це як розуміти? Перефразуй, будь ласка. 

виправив, йшлося про те що деякі завдання можна вирішити лише при використанні рекурсії

Спасибі дуже корисна стаття

А ще щось планується подібного найближчим часом?


Дякую за підтримку, радий що Вам сподобалось!

Так маю вже майже дороблений проект по управлінні Audio файлом, на заміну стандартним клавішам управління HTML5, але ще не встиг відтестувати програвання файлів з інтернету, поки лише локально працює

Надіюсь найближчим часом дороблю й закину

Рахунки

webmoneyeur - E385818210641
usd - Z304643423050
uah - U354026817492
rub - R301704373231easypay80002677bitcoin1F5HRGroUtEQW9HBNbeew8iKh5KQ8vJxzw

Зворотній зв'язок

Для покращення роботи сайту надсилайте свої зауваження:
mailЗауваження
mailПропозиція

Статистика

UkrNET - поисково-информационный ресурс

VBA : Діаграма карти України в Excel

При роботі з даними дуже часто постає необхідність в їх візуальному представленні, одним із способів представлення є нанесення даних на карту країни. Тож розглянемо як в Excel можна створити власну діаграму із довільною картою (на прикладі будемо розглядати карту України) та модулі для її управління.

Як результат отримаємо наступну карту:

карта України

Створення діаграми

Примітка: Для початку роботи необхідно буде мати зображення, карти, яку вам потрібно відтворити на діаграмі

Створюємо пусту діаграму і відкриваємо Формат області діаграми (в меню правої клавіші миші) і в розділі Заливка вибрати Зображення або текстура і вставити зображення вашої карти.

Наступним кроком будемо створювати фігури які будуть відповідати за кожну окрему область, даний крок буде найбільш часозатратний.

Для створення подібного роду фігур підходить Мальована крива вибрати її можна за шляхом ВСТАВЛЕННЯ/Фігури/Лінії.

карта України

Після створення об'єкту використовуємо Редагувати фігуру (блок 1 на мал. вище) та вибираємо Змінити точки, дозволяє більш точно розставити усі точки полілінії, щоб більш точно відтворити контури карти.

Далі замінюємо ім'я Полілінія№ (блок 2) на назву області за якою пізніше будемо звертатись до об'єкту, а також вона буде виводити при наведенні на об'єкт.

Також в властивостях фігури необхідно, щоб була виставлена властивість Змінювати розміри разом із діаграмою (блок 3) інакше об'єкти почнуть накладатись, або будуть розкидані по діаграмі при масштабуванні.

І таким чином вимальовуємо повністю всю карту із областей.

Позначки обласних центрів наносимо на карту за тими ж принципами.


Модуль управління

Для функціоналу діаграми буде забезпечено:
  1. Кольорова гама із 8 кольорів (White; Red; Fuchsia; Cyan; Green; Yellow; Blue; Black)
  2. Вибір кольору, для визначення градієнта від білого до обраного та заливки ним потрібної області
  3. Вибір кольору, для заливки межі областей та позначок обласного центру
  4. Вибір діапазону із назвами областей
  5. Вибір діапазону даних (за якими буде здійснюватись розподіл)
  6. Вибір діапазону підписів (які будуть додані до назви обласного центру)
  7. Вибір значення з якого починати розрахунок розподілу від 0, або від мінімального значення в діапазоні
  8. Вибір кількості груп на які необхідно ділити діапазон (вплине на відтінки кольорів при заливці)
  9. Вибір відображення позначок обласних центрів
  10. Вибір відображення підписів до позначок обласних центрів

Для зберігання властивостей діаграми буде використано додатковий аркуш (MapProperties), який буде прихований за замовчуванням

Для опрацювання властивостей використаємо Клас який буде їх об'єднувати, а також модуль аркуша де безпосередньо знаходиться діаграма

Модуль Класу

Змінні та константи:

Public viewCityPoint As Boolean
Public viewCityName As Boolean
Public colors As String
Public colorGrad As String
Public colorLine As String
Public groupCount As Integer
Public groupStartPosZero As Boolean
Public myTitleDataRange As Range
Public myDataRange As Range
Public myTitleDataRangeText As String
Public myDataRangeText As String
Public myTitleRange As Range
Public myTitleRangeText As String
Public curColorPaint As Integer
Public curSheet As String
Const diagram As String = "UkraineMap"
Const sheet As String = "MapProperties"

Властивості на отримання даних:

Public Property Get SheetName() As String
    SheetName = sheet
End Property
Public Property Get diagramName() As String
    diagramName = diagram
End Property
Public Property Get colorsList() As String
    colorsList = "White;Red;Fuchsia;Cyan;Green;Yellow;Blue;Black"
End Property
Public Property Get oblastList() As String
    oblastList = "Львівська,Волинська,Рівненська,Тернопільська,Івано-Франківська,Закарпатська,Чернівецька,Хмельницька,Вінницька,Житомирська,Київська,Одеська,Миколаївська,Херсонська,АР Крим,Чернігівська,Сумська,Харківська,Полтавська,Черкаська,Кіровоградська,Дніпропетровська,Запорізька,Донецька,Луганська"
End Property
Public Property Get cityList() As String
    cityList = "Львів,Луцьк,Рівне,Тернопіль,Івано-Франківськ,Ужгород,Чернівці,Хмельницьк,Вінниця,Житомир,Київ,Одеса,Миколаїв,Херсон,Сімферополь,Чернігів,Суми,Харків,Полтава,Черкаси,Кропивницький,Дніпро,Запоріжжя,Донецьк,Луганськ"
End Property 

Метод отримання даних про встановлені властивості діаграми. Якщо відсутній аркуш із потрібною інформацією створює його та наповняє значеннями за замовчуванням.

Public Sub getData()
Dim ws As Worksheet
    If checkSheetExist(sheet) Then
startPoint:
     Set Worksheet = ThisWorkbook.Sheets(sheet)
        colorGrad = Worksheet.Range("B1").Value
        colorLine = Worksheet.Range("B2").Value
        groupCount = Worksheet.Range("B3").Value
        groupStartPosZero = Worksheet.Range("B4").Value
        viewCityPoint = Worksheet.Range("B5").Value
        viewCityName = Worksheet.Range("B6").Value
        tempArr = Split(Worksheet.Range("B7").Value, "!")
            myTitleDataRangeText = Worksheet.Range("B7").Value
            Set myTitleDataRange = Sheets(tempArr(0)).Range(tempArr(1))
        tempArr = Split(Worksheet.Range("B8").Value, "!")
            myDataRangeText = Worksheet.Range("B8").Value
            Set myDataRange = Sheets(tempArr(0)).Range(tempArr(1))
        tempArr = Split(Worksheet.Range("B9").Value, "!")
            myTitleRangeText = Worksheet.Range("B9").Value
            Set myTitleRange = Sheets(tempArr(0)).Range(tempArr(1))
    Else
        Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        ws.Name = sheet
        ws.Visible = False
        ThisWorkbook.Sheets(sheet).Range("A1") = "Колір заливки"
        ThisWorkbook.Sheets(sheet).Range("A2") = "Колір межі"
        ThisWorkbook.Sheets(sheet).Range("A3") = "К-ть груп"
        ThisWorkbook.Sheets(sheet).Range("A4") = "Розрахунок груп з"
        ThisWorkbook.Sheets(sheet).Range("A5") = "Відображння позначки обл. центру"
        ThisWorkbook.Sheets(sheet).Range("A6") = "Відображення підписів обл. центру"
        ThisWorkbook.Sheets(sheet).Range("A7") = "Діапазон обл."
        ThisWorkbook.Sheets(sheet).Range("A8") = "Діапазон значень"
        ThisWorkbook.Sheets(sheet).Range("A9") = "Підписи значень"
        ThisWorkbook.Sheets(sheet).Range("B1") = "Red"
        ThisWorkbook.Sheets(sheet).Range("B2") = "Black"
        ThisWorkbook.Sheets(sheet).Range("B3") = 10
        ThisWorkbook.Sheets(sheet).Range("B4") = 0
        ThisWorkbook.Sheets(sheet).Range("B5") = 1
        ThisWorkbook.Sheets(sheet).Range("B6") = 1
        ThisWorkbook.Sheets(sheet).Range("B7") = curSheet & "!A2:A26"
        ThisWorkbook.Sheets(sheet).Range("B8") = curSheet & "!B2:B26"
        ThisWorkbook.Sheets(sheet).Range("B9") = curSheet & "!C2:C26"
        GoTo startPoint
    End If
End Sub 

Примітка: Якщо Вам необхідно опрацювати іншу карту то достатньо замінити переліки Областей (oblastList) та Обласних центрів (cityList), а також назву діаграми на свою в модулі класу

Метод для перевірки існування аркуша. Приймає лише один аргумент - назву аркуша який необхідно перевірити.

Public Function checkSheetExist(SheetName)
    For i = 1 To ThisWorkbook.Worksheets.Count
        If ThisWorkbook.Sheets(i).Name = SheetName Then checkSheetExist = True: Exit For
    Next i
End Function 

Метод, що визначає потрібний колір чи його градієнт для заливки фігур. Приймає два аргументи: color - назва потрібного кольору, та obj - назва об'єкту для якого визначається колір.

Public Function getRGB(color As String, obj As String)
    If color = "White" Then
        getRGB = RGB(255, 255, 255)
    ElseIf color = "Black" Then
        getRGB = RGB(0, 0, 0)
    ElseIf obj = "Fill" Then
        If color = "Red" Then
            getRGB = RGB(255, curColorPaint, curColorPaint)
        ElseIf color = "Green" Then
            getRGB = RGB(curColorPaint, 255, curColorPaint)
        ElseIf color = "Blue" Then
            getRGB = RGB(curColorPaint, curColorPaint, 255)
        ElseIf color = "Yellow" Then
            getRGB = RGB(255, 255, curColorPaint)
        ElseIf color = "Fuchsia" Then
            getRGB = RGB(255, curColorPaint, 255)
        ElseIf color = "Cyan" Then
            getRGB = RGB(curColorPaint, 255, 255)
        End If
    Else
        If color = "Red" Then
            getRGB = RGB(255, 0, 0)
        ElseIf color = "Green" Then
            getRGB = RGB(0, 255, 0)
        ElseIf color = "Blue" Then
            getRGB = RGB(0, 0, 255)
        ElseIf color = "Yellow" Then
            getRGB = RGB(255, 255, 0)
        ElseIf color = "Fuchsia" Then
            getRGB = RGB(255, 0, 255)
        ElseIf color = "Cyan" Then
            getRGB = RGB(0, 255, 255)
        End If
    End If
End Function 

Модуль Аркуша

Public diagramProperties As diagramProperties
Public Sub controlDiagram()
Dim cityArr() As String, oblastArr() As String, groupBound() As Double, colSum() As Variant, colTitle() As Variant
Dim myColor As Variant
    Me.Activate
    Set diagramProperties = New diagramProperties
    diagramProperties.curSheet = Me.Name
    diagramProperties.getData
    cityArr = Split(diagramProperties.cityList, ",")
    oblastArr = Split(diagramProperties.oblastList, ",")
    If diagramProperties.groupStartPosZero Then minValue = 0 Else minValue = WorksheetFunction.Min(diagramProperties.myDataRange)
    maxValue = WorksheetFunction.Max(diagramProperties.myDataRange)
    ReDim groupBound(diagramProperties.groupCount)
	
'розраховуємо діапазони значень для груп даних відповідно до заповнених властивостей та даних'
    groupBound(0) = minValue
    For i = 1 To diagramProperties.groupCount - 1
        groupBound(i) = groupBound(i - 1) + ((maxValue - minValue) / diagramProperties.groupCount)
    Next i
    groupBound(diagramProperties.groupCount) = maxValue
	
'створюємо масиви даних та їх підписи'
    ReDim colSum(UBound(cityArr)), colTitle(UBound(cityArr))
    For i = 1 To diagramProperties.myTitleDataRange.Count
        For j = 0 To UBound(cityArr)
            If diagramProperties.myTitleDataRange.Range("A" & i) = oblastArr(j) Then
                needCell = diagramProperties.myTitleRange.Range("A" & i)
                If needCell = Empty Then colTitle(j) = "" Else: colTitle(j) = needCell
                needCell = diagramProperties.myDataRange.Range("A" & i)
                If needCell = Empty Then colSum(j) = "" Else: colSum(j) = needCell: Exit For
            End If
        Next j
    Next i
	
'розпочинаємо робу із елементами діаграми'
    Set mapChart = ActiveSheet.ChartObjects(diagramProperties.diagramName)
    For i = 0 To UBound(cityArr)
        mapChart.Activate
'робота із областями'
        ActiveChart.Shapes.Range(Array(oblastArr(i))).Select
            Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 0, 0)		'заливка границі області'

'визначаємо відтінок кольору яким необхідно буде замальовувати фігуру відповідно її групи'
            diagramProperties.curColorPaint = 255
            For j = 1 To UBound(groupBound)
                If colSum(i) = 0 Then Exit For
                If colSum(i) > groupBound(j - 1) And colSum(i) <= groupBound(j) Then diagramProperties.curColorPaint = 255 - (255 / diagramProperties.groupCount * (j - 1)): Exit For
            Next j
			
'робота із областями'
            myColor = diagramProperties.getRGB(diagramProperties.colorGrad, "Fill")
            If colSum(i) <> "" Then
                With Selection.ShapeRange.Fill
                    .ForeColor.RGB = myColor		''заливка області
                    .Solid
                End With
            Else
                With Selection.ShapeRange.Fill		''заливка решіткою чорного кольору для областей по яких відсутні дані
                    .Visible = msoTrue
                    .ForeColor.RGB = RGB(0, 0, 0)
                    .BackColor.ObjectThemeColor = msoThemeColorBackground1
                    .BackColor.TintAndShade = 0
                    .BackColor.Brightness = 0
                    .Patterned msoPatternDottedGrid
                End With
            End If
            Selection.ShapeRange.Line.ForeColor.RGB = diagramProperties.getRGB(diagramProperties.colorLine, "Line")		'заливка межі області'
			
'робота із містами'
        If diagramProperties.viewCityPoint Then myColor = diagramProperties.getRGB(diagramProperties.colorLine, "Line")
        ActiveChart.Shapes.Range(Array(cityArr(i))).Select
            Selection.ShapeRange.Line.ForeColor.RGB = myColor		'заливка границі позначки міста'
            Selection.ShapeRange.Fill.ForeColor.RGB = myColor		'заливка позначки міста'
            If diagramProperties.viewCityName Then
                textSize = (ActiveChart.Parent.Width / 100) + 3		'визначаємо розмір тексту на основи ширини діаграми позначки міста'
                If colTitle(i) <> "" Then tempStr = Chr(13) & colTitle(i) Else tempStr = ""
                Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = cityArr(i) & tempStr		'назва обласного центру + підпис даних'
                With Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Font		'робота з текстом'
                    .Fill.ForeColor.RGB = RGB(0, 0, 0)		'колір тексту'
                    .Size = textSize		'розмір тексту'
                End With
            Else
                Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = ""
            End If
    Next i
    mapChart.Select
End Sub 

Кнопка для запуску форми (саму форму розглянемо трохи нижче).

Private Sub CommandButton1_Click()
    Set diagramProperties = New diagramProperties
    Me.Activate
    MapProperties.Show
End Sub 

При перерахунку даних аркуша перемалює діаграму

Private Sub Worksheet_Calculate()
    Call controlDiagram
End Sub 

При зміні значення у діапазоні із даними перемалює діаграму

Private Sub Worksheet_Change(ByVal Target As Range)
    Set diagramProperties = New diagramProperties
    diagramProperties.getData
    For i = 1 To diagramProperties.myDataRange.Count
        If Target.Address = diagramProperties.myDataRange.Range("A" & i).Address Or Target.Address = diagramProperties.myTitleRange.Range("A" & i).Address Then Call controlDiagram
    Next
End Sub 

Модуль Форми

Для зручності управління властивостями діаграми, створюємо форму наступного вигляду:

Властивості Діаграми

Відкриття форми буде відбуватись за натиском кнопки ActiveX на аркуші з діаграмою (CommandButton1_Click із модуля аркуша).

Код форми

Public diagramProperties As diagramProperties
Private Sub UserForm_Initialize()
    Set diagramProperties = New diagramProperties
    diagramProperties.curSheet = ActiveSheet.Name
    diagramProperties.getData
    tempArr = Split(diagramProperties.colorsList, ";")
    For i = 0 To UBound(tempArr)
        cbxOblColor.AddItem (tempArr(i))
        If diagramProperties.colorGrad = tempArr(i) Then cbxOblColor.Text = tempArr(i)
        cbxLineColor.AddItem (tempArr(i))
        If diagramProperties.colorLine = tempArr(i) Then cbxLineColor.Text = tempArr(i)
    Next i
    For i = 1 To 20
        cbxGroupCount.AddItem (i)
    Next i
    oblRange.Text = diagramProperties.myTitleDataRangeText
    dataRange.Text = diagramProperties.myDataRangeText
    titleRange.Text = diagramProperties.myTitleRangeText
    cbxGroupCount.Text = diagramProperties.groupCount
    If diagramProperties.groupStartPosZero Then obtZero.Value = True Else obtMin.Value = True
    chbxViewObl.Value = diagramProperties.viewCityPoint
    chbxViewOblTitle.Value = diagramProperties.viewCityName
End Sub
Private Sub cbSave_Click()
    Set wh = ThisWorkbook.Sheets(diagramProperties.SheetName)
    wh.Range("B1") = cbxOblColor.Text
    wh.Range("B2") = cbxLineColor.Text
    wh.Range("B3") = cbxGroupCount.Text
    If obtZero.Value Then wh.Range("A4") = 1 Else wh.Range("A4") = 0
    wh.Range("B5") = chbxViewObl.Value
    wh.Range("B6") = chbxViewOblTitle.Value
    wh.Range("B7") = oblRange.Text
    wh.Range("B8") = dataRange.Text
    wh.Range("B9") = titleRange.Text
    Call Аркуш1.controlDiagram 'якщо у Вас інша назва аркуша з діаграмою потрібно буде замінити на відповідну'
    Unload Me
End Sub
Private Sub cbCancel_Click()
    Unload Me
End Sub 
Карта України з даними

Файли для завантаження

Завантажити з


view1858like1dislike0 avatard_l4w clock 2017-06-20 07:58

Коментарі:



Для даної статті відсутні коментарі

Про нас

"Programmers World" розроблено з метою полегшення в освоєнні навичок програмування, та поширення матеріалів з сфери ІТ Українською мовою.

Кожен бажаючий може безкоштовно користуватися ресурсами сайту, щоб:

- Вивчати теоретичні аспекти мов програмування

- Переглядати практичне застосування теорії при виконанні різних міні проектів з відкритим кодом

- Розміщати свої завдання на форумі для допомоги в їх реалізації, або готового коду який може бути корисний іншим користувачам

- Спілкуватись з іншими користувачами та обмінюватись досвідом

Сайт функціонує на безопланій основі та ентузіазмі розробника, якщо Ви бажаєте долучитись до розвитку даного проекту то можете пожертвувати кошти на рахунки розміщені в блоці "Допомога сайту".

Сайт

Зареєстровані користувачі можуть скористатися системою діалогів, в профілі користувача, для отримання потрібної інформації. Написати!

Також Ви можете використати форми відправки Зауважень та Пропозицій.


Електронна пошта

Ви можете звертатись на нашу поштову скриньку site.programmersworld@gmail.com

www.000webhost.com