Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Размещение надписи по центру линии - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Размещение надписи по центру линии (Макросы/Sub)
Размещение надписи по центру линии
Glass4217 Дата: Вторник, 05.03.2019, 14:22 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 28
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Всем привет.
У меня есть макрос рисующий линии по таблице.

Вот подскажите - как реализовать такую идею.
В строке 8 этой таблицы - указан некий текст.

Как при запуске макроса - расставлять этот текст - по центру нарисованной линии (без наклона) - для соответствующего столбца ?
Речь идет либо о прямоугольнике либо о текстбоксе с вписанным в него текстом.

Сейчас макрос просто рисует просто линии - без надписи по центру.
К сообщению приложен файл: 3748647.rar(80.7 Kb)
 
Ответить
СообщениеВсем привет.
У меня есть макрос рисующий линии по таблице.

Вот подскажите - как реализовать такую идею.
В строке 8 этой таблицы - указан некий текст.

Как при запуске макроса - расставлять этот текст - по центру нарисованной линии (без наклона) - для соответствующего столбца ?
Речь идет либо о прямоугольнике либо о текстбоксе с вписанным в него текстом.

Сейчас макрос просто рисует просто линии - без надписи по центру.

Автор - Glass4217
Дата добавления - 05.03.2019 в 14:22
krosav4ig Дата: Вторник, 05.03.2019, 19:51 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1982
Репутация: 840 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Glass4217, намучаетесь вы еще с такими именами переменных...
[vba]
Код
Sub Вариант_1()
    Dim c_x1y1 As Range, c_x2y2 As Range, x#, y#, i%, h#
    
    lastcol = Cells(2, Columns.Count).End(xlToLeft).Column
    
    Set c_x1y1 = Range(Cells(2, 2), Cells(3, lastcol))
    Set c_x2y2 = Range(Cells(6, 2), Cells(7, lastcol))
    
    With ActiveSheet.Shapes
        On Error Resume Next
        i = 1
        Do While Err = 0
            .Item("line " & i).Delete
            .Item("label " & i).Delete
            i = i + 1
        Loop
        On Error GoTo 0
        For i = 1 To lastcol - 1
            x = c_x1y1(1, i) + (c_x2y2(1, i) - c_x1y1(1, i) - c_x1y1(1, 1).Width) / 2
            y = c_x1y1(2, i) + (c_x2y2(2, i) - c_x1y1(2, i) - c_x1y1(7, 1).Height) / 2
            With .AddConnector(1, c_x1y1(1, i), c_x1y1(2, i), c_x2y2(1, i), c_x2y2(2, i))
                .Name = "line " & i
            End With
            With .AddTextbox(1, x, y, c_x1y1(1, i).Width, c_x1y1(7, i).Height)
                .Name = "label " & i
                h = .Height
                With .TextFrame
                    .Characters.Text = c_x1y1(7, i)
                    .HorizontalAlignment = xlHAlignCenter
                    .VerticalAlignment = xlVAlignCenter
                    .MarginBottom = 0: .MarginLeft = 0
                    .MarginRight = 0: .MarginTop = 0
                    .AutoSize = True
                End With
                If .Height <> h Then .Top = .Top - (.Height - h) / 2
            End With
        Next i
    End With
End Sub
[/vba]


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
СообщениеGlass4217, намучаетесь вы еще с такими именами переменных...
[vba]
Код
Sub Вариант_1()
    Dim c_x1y1 As Range, c_x2y2 As Range, x#, y#, i%, h#
    
    lastcol = Cells(2, Columns.Count).End(xlToLeft).Column
    
    Set c_x1y1 = Range(Cells(2, 2), Cells(3, lastcol))
    Set c_x2y2 = Range(Cells(6, 2), Cells(7, lastcol))
    
    With ActiveSheet.Shapes
        On Error Resume Next
        i = 1
        Do While Err = 0
            .Item("line " & i).Delete
            .Item("label " & i).Delete
            i = i + 1
        Loop
        On Error GoTo 0
        For i = 1 To lastcol - 1
            x = c_x1y1(1, i) + (c_x2y2(1, i) - c_x1y1(1, i) - c_x1y1(1, 1).Width) / 2
            y = c_x1y1(2, i) + (c_x2y2(2, i) - c_x1y1(2, i) - c_x1y1(7, 1).Height) / 2
            With .AddConnector(1, c_x1y1(1, i), c_x1y1(2, i), c_x2y2(1, i), c_x2y2(2, i))
                .Name = "line " & i
            End With
            With .AddTextbox(1, x, y, c_x1y1(1, i).Width, c_x1y1(7, i).Height)
                .Name = "label " & i
                h = .Height
                With .TextFrame
                    .Characters.Text = c_x1y1(7, i)
                    .HorizontalAlignment = xlHAlignCenter
                    .VerticalAlignment = xlVAlignCenter
                    .MarginBottom = 0: .MarginLeft = 0
                    .MarginRight = 0: .MarginTop = 0
                    .AutoSize = True
                End With
                If .Height <> h Then .Top = .Top - (.Height - h) / 2
            End With
        Next i
    End With
End Sub
[/vba]

Автор - krosav4ig
Дата добавления - 05.03.2019 в 19:51
Glass4217 Дата: Среда, 06.03.2019, 01:32 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 28
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
krosav4ig, спасибо вам большое.
Теперь все работает как надо.
 
Ответить
Сообщениеkrosav4ig, спасибо вам большое.
Теперь все работает как надо.

Автор - Glass4217
Дата добавления - 06.03.2019 в 01:32
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Размещение надписи по центру линии (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2019 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!