Справочник функций

Ваш аккаунт

Войти через: 
Забыли пароль?
Регистрация
Информацию о новых материалах можно получать и без регистрации:

Почтовая рассылка

Подписчиков: -1
Последний выпуск: 19.06.2015

Как сохранить формат шрифта ячейки при назначении/удалении гиперссылки ячейки Excel

88K
05 августа 2013 года
andrey-750
3 / / 05.08.2013
Приветствую участников форума!
А вот не подскажет ли кто, как назначить гиперссылку ячейке таким образом, чтобы сохранить все форматы использованных в этой ячейке шрифтов?
Т.е. В ячейке присутствует шрифт разных форматов (цвет, размер, подчеркнутый/зачёркнутый, надстрочный/подстрочный и т.п.) Так вот, при назначении гиперссылки этой ячейке (без разницы - вручную через меню или через VBA - ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="C:\Windows\") весь текст становится синим, подчёрткнутым, одного размера. Примерно та же картина при удалении гиперссылки, только цвета сохраняются, зато убирается "перенос по словам" и выравнивание становится "по нижнему краю".
А хотелось бы оставить форматирование как было до назначения гиперссылки.

Вот, попробовал перед назначением гиперссылки скопировать ячейку на другой лист, а затем посимвольно восстанавливать формат:
Код:
Sub StrongHL()  
RowNum = Selection.Row()  
ColNum = Selection.Column()  
ActiveSheet.Cells(RowNum, ColNum).Copy  
Sheets("Лист_для_технических_целей").Select  
Range("A7").Select  
ActiveSheet.Paste  
Sheets("Рабочий_лист").Select  
ActiveSheet.Cells(RowNum, ColNum).Select  
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="C:\Windows\"  
For j = 1 To Len(ActiveSheet.Cells(RowNum, ColNum).Value)  
    With ActiveCell.Characters(Start:=j, Length:=1).Font  
        .Name = Worksheets("Лист_для_технических_целей").Range("A7").Characters(Start:=j, Length:=1).Font.Name  
        .FontStyle = Worksheets("Лист_для_технических_целей").Range("A7").Characters(Start:=j, Length:=1).Font.FontStyle  
        .Size = Worksheets("Лист_для_технических_целей").Range("A7").Characters(Start:=j, Length:=1).Font.Size  
        .Strikethrough = Worksheets("Лист_для_технических_целей").Range("A7").Characters(Start:=j, Length:=1).Font.Strikethrough  
        .Superscript = Worksheets("Лист_для_технических_целей").Range("A7").Characters(Start:=j, Length:=1).Font.Superscript  
        .Subscript = Worksheets("Лист_для_технических_целей").Range("A7").Characters(Start:=j, Length:=1).Font.Subscript  
        .OutlineFont = Worksheets("Лист_для_технических_целей").Range("A7").Characters(Start:=j, Length:=1).Font.OutlineFont  
        .Shadow = Worksheets("Лист_для_технических_целей").Range("A7").Characters(Start:=j, Length:=1).Font.Shadow  
        .Underline = Worksheets("Лист_для_технических_целей").Range("A7").Characters(Start:=j, Length:=1).Font.Underline  
        .ColorIndex = Worksheets("Лист_для_технических_целей").Range("A7").Characters(Start:=j, Length:=1).Font.ColorIndex  
        .TintAndShade = Worksheets("Лист_для_технических_целей").Range("A7").Characters(Start:=j, Length:=1).Font.TintAndShade  
        .ThemeFont = Worksheets("Лист_для_технических_целей").Range("A7").Characters(Start:=j, Length:=1).Font.ThemeFont  
    End With  
Next  
End Sub
Работает, но ужасно медленно - Ячейка в 200 символов восстанавливает формат аж 12 секунд!
Если отключить вывод на экран в процессе выполнения цикла (Application.ScreenUpdating = False), удаётся сократить время выполнения примерно вдвое.

Может есть какие-нибудь ключики для Hyperlinks.Add или .PasteSpecial или что-то подобное, чтобы делать сие одной командой, без цикла по каждой букве?
И ещё: нельзя ли скопировать ячейку на другой лист, не переключаясь на него? Т.е. кусок кода:
 
Код:
Sheets("Лист_для_технических_целей").Select  
    Range("A7").Select  
    ActiveSheet.Paste  
    Sheets("Рабочий_лист").Select  
    ActiveSheet.Cells(RowNum, ColNum).Select
хотелось бы заменить чем-нибудь вроде: Sheets("Лист_для_технических_целей").Range("A7").Paste - но это не работает (хотя то же с .Copy работает)
78K
06 августа 2013 года
EsEr
20 / / 17.02.2013
Сначала ответ на второй код - можно, не нужно выбирать лист или ячейку для того чтобы назначить ей значение(то есть работаем без метода Select)
78K
06 августа 2013 года
EsEr
20 / / 17.02.2013
По поводу первого могу сразу сказать что заставить его работать раз в 10 быстрее можно назначением постоянных значений(объектов) переменным, то есть
dim лист as object
....
лист=Worksheets("Лист_для_технических_целей").Range("A7")
и вообще гораздо быстрее будет работать код выполняющий копирование значений с исходной ячейки в переменные, а затем после действия пользователя восстанавливать эти значения из переменных.
275
07 августа 2013 года
pashulka
985 / / 19.09.2004
andrey-750, а если не восстанавливать исходные параметры форматирования, а не допускать их изменений, использовав для этого стиль Гиперссылка (XL97-2003 Формат-Стиль-Имя стиля) ... т.е. просто убрать "флажок" напротив Шрифт.
88K
07 августа 2013 года
andrey-750
3 / / 05.08.2013
Спасибо всем откликнувшимся.
Проблема решилась следующим способом: Сначала запоминаем текущее состояние стилей "Гиперссылка" (для назначения гиперссылки) и "Обычный" (для удаления гиперссылки), затем сбрасываем все "флажки" изменений при применении этого стиля. Потом назначаем гиперссылку (предварительно удалив старую) и возвращаем исходные состояния "флажков" стилей. Для ускорения на время работы отключаем отражение изменений на экране.
Код:
Dim sHLIncludeNumber, sHLIncludeFont, sHLIncludeAlignment, sHLIncludeBorder, sHLIncludePatterns, sHLIncludeProtection As String
Dim sNMIncludeNumber, sNMIncludeFont, sNMIncludeAlignment, sNMIncludeBorder, sNMIncludePatterns, sNMIncludeProtection As String
    Application.ScreenUpdating = 0: Application.Calculation = xlManual
    With ActiveWorkbook.Styles("Hyperlink")
        sHLIncludeNumber = .IncludeNumber: .IncludeNumber = False
        sHLIncludeFont = .IncludeFont: .IncludeFont = False
        sHLIncludeAlignment = .IncludeAlignment: .IncludeAlignment = False
        sHLIncludeBorder = .IncludeBorder: .IncludeBorder = False
        sHLIncludePatterns = .IncludePatterns: .IncludePatterns = False
        sHLIncludeProtection = .IncludeProtection: .IncludeProtection = False
    End With

    With ActiveWorkbook.Styles("Normal")
        sNMIncludeNumber = .IncludeNumber: .IncludeNumber = False
        sNMIncludeFont = .IncludeFont: .IncludeFont = False
        sNMIncludeAlignment = .IncludeAlignment: .IncludeAlignment = False
        sNMIncludeBorder = .IncludeBorder: .IncludeBorder = False
        sNMIncludePatterns = .IncludePatterns: .IncludePatterns = False
        sNMIncludeProtection = .IncludeProtection: .IncludeProtection = False
    End With

    Selection.Hyperlinks.Delete
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="http://forum.codenet.ru"

    With ActiveWorkbook.Styles("Hyperlink")
        .IncludeNumber = sHLIncludeNumber
        .IncludeFont = sHLIncludeFont
        .IncludeAlignment = sHLIncludeAlignment
        .IncludeBorder = sHLIncludeBorder
        .IncludePatterns = sHLIncludePatterns
        .IncludeProtection = sHLIncludeProtection
    End With

    With ActiveWorkbook.Styles("Normal")
        .IncludeNumber = sNMIncludeNumber
        .IncludeFont = sNMIncludeFont
        .IncludeAlignment = sNMIncludeAlignment
        .IncludeBorder = sNMIncludeBorder
        .IncludePatterns = sNMIncludePatterns
        .IncludeProtection = sNMIncludeProtection
    End With
    Application.ScreenUpdating = 1: Application.Calculation = xlAutomatic
275
07 августа 2013 года
pashulka
985 / / 19.09.2004
Т.е. Вы всё-таки извернулись через стиль гиперссылки ...

по поводу кода, с чего Вы взяли As String ? True/False это тип Boolean,

кроме того, в VB(A), в отличии от других языков :

 
Код:
Dim boolHLIncludeNumber As Boolean, boolHLIncludeFont As Boolean, boolHLIncludeProtection As Boolean
Хотя можно и просто использовать инструкцию DefТип, в Вашем случае, это DefBool B

Код:
DefBool B

Private Sub Test()
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
   
    With ActiveWorkbook.Styles("Hyperlink")
         boolHLIncludeNumber = .IncludeNumber: .IncludeNumber = False
         boolHLIncludeFont = .IncludeFont: .IncludeFont = False
         boolHLIncludeAlignment = .IncludeAlignment: .IncludeAlignment = False
         boolHLIncludeBorder = .IncludeBorder: .IncludeBorder = False
         boolHLIncludePatterns = .IncludePatterns: .IncludePatterns = False
         boolHLIncludeProtection = .IncludeProtection: .IncludeProtection = False
    End With
   
    Selection.Hyperlinks.Add Anchor:=Selection, Address:="http://forum.codenet.ru/questions/theme/13"

    With ActiveWorkbook.Styles("Hyperlink")
         .IncludeNumber = boolHLIncludeNumber
         .IncludeFont = boolHLIncludeFont
         .IncludeAlignment = boolHLIncludeAlignment
         .IncludeBorder = boolHLIncludeBorder
         .IncludePatterns = boolHLIncludePatterns
         .IncludeProtection = boolHLIncludeProtection
    End With
   
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
End Sub
88K
08 августа 2013 года
andrey-750
3 / / 05.08.2013
То pashulka:
Наверное, Вы правы, но у меня всё работает именно в таком виде, как я опубликовал здесь. Наверное, VBA прощает мне "чайниковские" ошибки...
275
09 августа 2013 года
pashulka
985 / / 19.09.2004
andrey-750, Можете не сомневаться, именно прощает ... тем более, что несмотря на префикс :) у Вас только две строковые(string) переменные, а именно sHLIncludeProtection и sNMIncludeProtection , все остальные вариантные(т.е. variant)

но дабы рассеять сомнения, по поводу типа, предлагаю провести небольшой тест, или просто выделить в редакторе, например, IncludeProtection и воспользоваться клавишей F1

 
Код:
Private Sub Test()
    MsgBox TypeName(ActiveWorkbook.Styles("Normal").IncludeProtection)
End Sub

Знаете кого-то, кто может ответить? Поделитесь с ним ссылкой.

Ваш ответ

Реклама на сайте | Обмен ссылками | Ссылки | Экспорт (RSS) | Контакты
Добавить статью | Добавить исходник | Добавить хостинг-провайдера | Добавить сайт в каталог