Как сохранить формат шрифта ячейки при назначении/удалении гиперссылки ячейки Excel
Приветствую участников форума!
А вот не подскажет ли кто, как назначить гиперссылку ячейке таким образом, чтобы сохранить все форматы использованных в этой ячейке шрифтов?
Т.е. В ячейке присутствует шрифт разных форматов (цвет, размер, подчеркнутый/зачёркнутый, надстрочный/подстрочный и т.п.) Так вот, при назначении гиперссылки этой ячейке (без разницы - вручную через меню или через VBA - ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="C:\Windows\") весь текст становится синим, подчёрткнутым, одного размера. Примерно та же картина при удалении гиперссылки, только цвета сохраняются, зато убирается "перенос по словам" и выравнивание становится "по нижнему краю".
А хотелось бы оставить форматирование как было до назначения гиперссылки.
Вот, попробовал перед назначением гиперссылки скопировать ячейку на другой лист, а затем посимвольно восстанавливать формат:
Работает, но ужасно медленно - Ячейка в 200 символов восстанавливает формат аж 12 секунд!
Если отключить вывод на экран в процессе выполнения цикла (Application.ScreenUpdating = False), удаётся сократить время выполнения примерно вдвое.
Может есть какие-нибудь ключики для Hyperlinks.Add или .PasteSpecial или что-то подобное, чтобы делать сие одной командой, без цикла по каждой букве?
И ещё: нельзя ли скопировать ячейку на другой лист, не переключаясь на него? Т.е. кусок кода:
хотелось бы заменить чем-нибудь вроде: Sheets("Лист_для_технических_целей").Range("A7").Paste - но это не работает (хотя то же с .Copy работает)
А вот не подскажет ли кто, как назначить гиперссылку ячейке таким образом, чтобы сохранить все форматы использованных в этой ячейке шрифтов?
Т.е. В ячейке присутствует шрифт разных форматов (цвет, размер, подчеркнутый/зачёркнутый, надстрочный/подстрочный и т.п.) Так вот, при назначении гиперссылки этой ячейке (без разницы - вручную через меню или через 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
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
Если отключить вывод на экран в процессе выполнения цикла (Application.ScreenUpdating = False), удаётся сократить время выполнения примерно вдвое.
Может есть какие-нибудь ключики для Hyperlinks.Add или .PasteSpecial или что-то подобное, чтобы делать сие одной командой, без цикла по каждой букве?
И ещё: нельзя ли скопировать ячейку на другой лист, не переключаясь на него? Т.е. кусок кода:
Код:
Sheets("Лист_для_технических_целей").Select
Range("A7").Select
ActiveSheet.Paste
Sheets("Рабочий_лист").Select
ActiveSheet.Cells(RowNum, ColNum).Select
Range("A7").Select
ActiveSheet.Paste
Sheets("Рабочий_лист").Select
ActiveSheet.Cells(RowNum, ColNum).Select
Сначала ответ на второй код - можно, не нужно выбирать лист или ячейку для того чтобы назначить ей значение(то есть работаем без метода Select)
По поводу первого могу сразу сказать что заставить его работать раз в 10 быстрее можно назначением постоянных значений(объектов) переменным, то есть
dim лист as object
....
лист=Worksheets("Лист_для_технических_целей").Range("A7")
и вообще гораздо быстрее будет работать код выполняющий копирование значений с исходной ячейки в переменные, а затем после действия пользователя восстанавливать эти значения из переменных.
dim лист as object
....
лист=Worksheets("Лист_для_технических_целей").Range("A7")
и вообще гораздо быстрее будет работать код выполняющий копирование значений с исходной ячейки в переменные, а затем после действия пользователя восстанавливать эти значения из переменных.
andrey-750, а если не восстанавливать исходные параметры форматирования, а не допускать их изменений, использовав для этого стиль Гиперссылка (XL97-2003 Формат-Стиль-Имя стиля) ... т.е. просто убрать "флажок" напротив Шрифт.
Спасибо всем откликнувшимся.
Проблема решилась следующим способом: Сначала запоминаем текущее состояние стилей "Гиперссылка" (для назначения гиперссылки) и "Обычный" (для удаления гиперссылки), затем сбрасываем все "флажки" изменений при применении этого стиля. Потом назначаем гиперссылку (предварительно удалив старую) и возвращаем исходные состояния "флажков" стилей. Для ускорения на время работы отключаем отражение изменений на экране.
Проблема решилась следующим способом: Сначала запоминаем текущее состояние стилей "Гиперссылка" (для назначения гиперссылки) и "Обычный" (для удаления гиперссылки), затем сбрасываем все "флажки" изменений при применении этого стиля. Потом назначаем гиперссылку (предварительно удалив старую) и возвращаем исходные состояния "флажков" стилей. Для ускорения на время работы отключаем отражение изменений на экране.
Код:
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
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
Т.е. Вы всё-таки извернулись через стиль гиперссылки ...
по поводу кода, с чего Вы взяли As String ? True/False это тип Boolean,
кроме того, в VB(A), в отличии от других языков :
Хотя можно и просто использовать инструкцию DefТип, в Вашем случае, это DefBool B
по поводу кода, с чего Вы взяли As String ? True/False это тип Boolean,
кроме того, в VB(A), в отличии от других языков :
Код:
Dim boolHLIncludeNumber As Boolean, boolHLIncludeFont As Boolean, boolHLIncludeProtection As Boolean
Код:
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
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
То pashulka:
Наверное, Вы правы, но у меня всё работает именно в таком виде, как я опубликовал здесь. Наверное, VBA прощает мне "чайниковские" ошибки...
Наверное, Вы правы, но у меня всё работает именно в таком виде, как я опубликовал здесь. Наверное, VBA прощает мне "чайниковские" ошибки...
andrey-750, Можете не сомневаться, именно прощает ... тем более, что несмотря на префикс :) у Вас только две строковые(string) переменные, а именно sHLIncludeProtection и sNMIncludeProtection , все остальные вариантные(т.е. variant)
но дабы рассеять сомнения, по поводу типа, предлагаю провести небольшой тест, или просто выделить в редакторе, например, IncludeProtection и воспользоваться клавишей F1
но дабы рассеять сомнения, по поводу типа, предлагаю провести небольшой тест, или просто выделить в редакторе, например, IncludeProtection и воспользоваться клавишей F1
Код:
Private Sub Test()
MsgBox TypeName(ActiveWorkbook.Styles("Normal").IncludeProtection)
End Sub
MsgBox TypeName(ActiveWorkbook.Styles("Normal").IncludeProtection)
End Sub