Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Рисование в Excel по данным из таблицы
 
#1
07.03.2018 08:39:44
Добрый день.
Есть файл с данными (приложил) 2 столбца - Название / длина. Возможно ли програмно нарисовать по этой таблице, что-то вроде того, что отображено на рисунке из приложения? (т.е. построение прямоугольников друг под другом, где цвет указывает на столбец А, а высота на столбец Б, ширина 0.1) Если возможно, может быть какие-то примеры, советы.
Ах да, таблица каждый раз изменяется:)
 
 
 
#2
07.03.2018 08:43:33
Цитата
DooJeWoo написал:
где цвет указывает на столбец А
там порода, а не цвет. Я например не знаю каким цветом Сильвинит красится. :)
Можно макросом.
 
 
 
#3
07.03.2018 08:47:12
V, цвета изменить не проблема)) Я рисунок по этой таблице накидал глина серая, соль желтая, сильвинит красный
 
 
 
#4
07.03.2018 09:20:48
Чем не подходит график Stacked Column? Ну разве что цвета расставлять.

альтернатива -условное форматирование.
Изменено: БМВ - 07.03.2018 09:30:10
По вопросам из тем форума, личку не читаю.
 
 
 
#5
07.03.2018 09:22:55
БМВ, таблица будет возможно на 1000+ строк
 
 
 
#6
07.03.2018 09:27:56
заготовка
Код
Sub Макрос1()
L = 200: X = 200: Y = 50
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
  H = Cells(i, 2) * 100
    With ActiveSheet.Shapes.AddShape(msoShapeRectangle, X, Y, L, H)
      .Fill.ForeColor.RGB = vbBlue
     .Line.ForeColor.RGB = vbBlue
  End With
  Y = Y + H + 5
Next
End Sub
 
 
 
#7
07.03.2018 09:36:27
V, нифига не понимаю как это работает) Пробелов не должно быть, это я  рисунок не правильно изобразил. Распишите если не трудно
Изменено: DooJeWoo - 07.03.2018 09:36:49
 
 
 
#8
07.03.2018 09:42:52
Цитата
DooJeWoo написал:
Пробелов не должно быть
уберите +5
 
 
 
#9
07.03.2018 09:51:11
2. Х - отступ от левого края окна, L - ширина прямоугольника, Y - отступ от верха окна
3. Цикл от 2 строки до последней заполненной
4. Высота прямоугольника = значению из ячейки увеличенному на 100 т,к. 0,1 мелковато будет
5. Работаем с созданным прямоугольником
6. заливка прямоугольника цветом (синий)
7. цвет линии прямоугольника делаем такой же как основной фон фигуры.
8. конец работы с созданным прямоугольником
9. меняем координату отступа от верха = текущая координата + высота прямоугольника+5 (+5 это зазор если нужен)
10. конец цикла
Изменено: V - 07.03.2018 09:51:45
 
 
 
#10
07.03.2018 09:51:42
БМВ, а разве условное форматирование дает возможность изменить высоту ячейки в соответствии с соседним столбцом?
 
 
 
#11
07.03.2018 09:52:23
А диаграммы, как ув.БМВ, намекал, не решают вопрос?

З.Ы. А, ну тогда ладно. :)
Тогда, конечно, сразу код - оптимальнее.
Изменено: Пытливый - 07.03.2018 13:18:33
Кому решение нужно - тот пример и рисует.
 
 
 
#12
07.03.2018 09:53:59
DooJeWoo,  просто меняется взгляд на ячейку
Естесвенно это пример
Изменено: БМВ - 07.03.2018 10:07:05
По вопросам из тем форума, личку не читаю.
 
 
 
#13
07.03.2018 09:59:02
Пытливый,
Цитата
DooJeWoo написал:
на 1000+ строк
Каждый слой красить руками или писать код .  Лучше сразу код или не диаграмма.
По вопросам из тем форума, личку не читаю.
 
 
 
#14
07.03.2018 10:01:19
Мой вариант. Таблица с результатом  нормально масштабируется вниз. Если не нужны названия слоёв - можно сделать формат чисел как в ячейке "F1"
Я не волшебник, я только учусь.
 
 
 
#15
07.03.2018 10:09:09
Вариант. Цвет породы берется из цвета заливки ячеек со значениями. Можно макрос привязать к событию изменения значений (например)
Код
Sub SolidColor()
Dim cl As Range
Dim iShp As Shape
Dim arrNm()
Dim lRow&, iLeft&, iTop&, iCol&, r&, g&, b&, I&
Application.ScreenUpdating = False
On Error Resume Next
With ActiveSheet
    .Shapes("tempName").Delete
    lRow = .Cells(.Rows.Count, 2).End(xlUp).Row
    iLeft = .Range("E2").Left
    iTop = .Range("E2").Top
    For Each cl In .Range("B2:B" & lRow).Cells
        iCol = cl.Interior.Color: b = Int(iCol / 65536): g = Int((iCol - b * 65536) / 256): r = (iCol - b * 65536) - (g * 256)
        Set iShp = .Shapes.AddShape(msoShapeRectangle, iLeft, iTop, 150, 100 * cl.Value)
        ReDim Preserve arrNm(I)
        arrNm(I) = iShp.Name
        With iShp
            .Line.Visible = msoFalse
            .Fill.ForeColor.RGB = RGB(r, g, b)
        End With
        iTop = iShp.Top + 100 * cl.Value
        I = I + 1
    Next
    Set iShp = .Shapes.Range(arrNm).Group
    iShp.Name = "tempName"
End With
Application.ScreenUpdating = True
End Sub
Согласие есть продукт при полном непротивлении сторон
 
 
 
#16
07.03.2018 10:47:32
Пытливый, Wiss, Спасибо, но все же с диаграммами вариант не катит.
V, спасибо за помощь, очень годный вариант.
Цитата
БМВ написал:
Каждый слой красить руками или писать код
БМВ, руками сейчас это все и делается, не то. А писать хороший код я не способен))
Sanja, Спасибо, вы лучший)) Не 1-ый раз мне помогаете, как и БМВ. Ваш вариант очень даже подходит!
 
 
 
#17
05.04.2018 14:58:58
Можно ли как-нибудь изменить код, чтобы цвет прямоугольника брался не только из заливки, а например добавлял штриховку( и ее цвет) и прочее???
Код
Sub SolidColor()
Dim cl As Range
Dim iShp As Shape
Dim arrNm()
Dim lRow&, iLeft&, iTop&, iCol&, r&, g&, b&, I&
Application.ScreenUpdating = False
On Error Resume Next
With ActiveSheet
    .Shapes("tempName").Delete
    lRow = .Cells(.Rows.Count, 2).End(xlUp).Row
    iLeft = .Range("E2").Left
    iTop = .Range("E2").Top
    For Each cl In .Range("B2:B" & lRow).Cells
        iCol = cl.Interior.Color: b = Int(iCol / 65536): g = Int((iCol - b * 65536) / 256): r = (iCol - b * 65536) - (g * 256)
        Set iShp = .Shapes.AddShape(msoShapeRectangle, iLeft, iTop, 150, 100 * cl.Value)
        ReDim Preserve arrNm(I)
        arrNm(I) = iShp.Name
        With iShp
            .Line.Visible = msoFalse
            .Fill.ForeColor.RGB = RGB(r, g, b)
        End With
        iTop = iShp.Top + 100 * cl.Value
        I = I + 1
    Next
    Set iShp = .Shapes.Range(arrNm).Group
    iShp.Name = "tempName"
End With
Application.ScreenUpdating = True
End Sub
Изменено: DooJeWoo - 05.04.2018 14:59:39
 
 
 
#18
05.04.2018 15:36:59
Цитата
V написал: не знаю каким цветом Сильвинит красится. Можно макросом.
Цвет макроса в каком спектре? :)
 
 
 
Страницы: 1
Наверх