У меня есть ячейка, на которую ссылаются ="Dealer: " & CustomerName.
CustomerName - это имя, на которое ссылается словарь. Как я мог смело выбирать только "Дилер", а не имя Клиента.
Пример:
Дилер: Джош
Я пробовал
Cells(5, 1).Characters(1, 7).Font.Bold = True
Но он работает только на незарегистрированных ячейках. Как я могу заставить это работать над ссылочной ячейкой?
Вы можете использовать приведенную ниже функцию, чтобы полужирный текст ввода внутри формулы
Итак, в вашей ячейке теперь вы можете ввести = Bold ( "Дилер:" ) & CustomerName
Чтобы быть точным - это будет только обманывать алфавитные символы (от a до z и от A до Z), все остальные останутся без изменений. Я не тестировал его на разных платформах, но, похоже, работает на моем. Может не поддерживаться для всех шрифтов.
Function Bold(sIn As String)
Dim sOut As String, Char As String
Dim Code As Long, i As Long
Dim Bytes(0 To 3) As Byte
Bytes(0) = 53
Bytes(1) = 216
For i = 1 To Len(sIn)
Char = Mid(sIn, i, 1)
Code = Asc(Char)
If (Code > 64 And Code < 91) Or (Code > 96 And Code < 123) Then
Code = Code + IIf(Code > 96, 56717, 56723)
Bytes(2) = Code Mod 256
Bytes(3) = Code \ 256
Char = Bytes
End If
sOut = sOut & Char
Next i
Bold = sOut
End Function
Edit:
Сделали попытку реорганизовать выше, чтобы показать, как это работает, а не намазывать магическими цифрами.
Function Bold(ByRef sIn As String) As String
' Maps an input string to the Mathematical Bold Sans Serif characters of Unicode
' Only works for Alphanumeric charactes, will return all other characters unchanged
Const ASCII_UPPER_A As Byte = &H41
Const ASCII_UPPER_Z As Byte = &H5A
Const ASCII_LOWER_A As Byte = &H61
Const ASCII_LOWER_Z As Byte = &H7A
Const ASCII_DIGIT_0 As Byte = &H30
Const ASCII_DIGIT_9 As Byte = &H39
Const UNICODE_SANS_BOLD_UPPER_A As Long = &H1D5D4
Const UNICODE_SANS_BOLD_LOWER_A As Long = &H1D5EE
Const UNICODE_SANS_BOLD_DIGIT_0 As Long = &H1D7EC
Dim sOut As String
Dim Char As String
Dim Code As Long
Dim i As Long
For i = 1 To Len(sIn)
Char = Mid(sIn, i, 1)
Code = AscW(Char)
Select Case Code
Case ASCII_UPPER_A To ASCII_UPPER_Z
' Upper Case Letter
sOut = sOut & ChrWW(UNICODE_SANS_BOLD_UPPER_A + Code - ASCII_UPPER_A)
Case ASCII_LOWER_A To ASCII_LOWER_Z
' Lower Case Letter
sOut = sOut & ChrWW(UNICODE_SANS_BOLD_LOWER_A + Code - ASCII_LOWER_A)
Case ASCII_DIGIT_0 To ASCII_DIGIT_9
' Digit
sOut = sOut & ChrWW(UNICODE_SANS_BOLD_DIGIT_0 + Code - ASCII_DIGIT_0)
Case Else:
' Not available as bold, return input character
sOut = sOut & Char
End Select
Next i
Bold = sOut
End Function
Function ChrWW(ByRef Unicode As Long) As String
' Converts from a Unicode to a character,
' Includes the Supplementary Tables which are not normally reachable using the VBA ChrW function
Const LOWEST_UNICODE As Long = &H0 '<--- Lowest value available in unicode
Const HIGHEST_UNICODE As Long = &H10FFFF '<--- Highest vale available in unicode
Const SUPPLEMENTARY_UNICODE As Long = &H10000 '<--- Beginning of Supplementary Tables in Unicode. Also used in conversion to UTF16 Code Units
Const TEN_BITS As Long = &H400 '<--- Ten Binary Digits - equivalent to 2^10. Used in converstion to UTF16 Code Units
Const HIGH_SURROGATE_CONST As Long = &HD800 '<--- Constant used in conversion from unicode to UTF16 Code Units
Const LOW_SURROGATE_CONST As Long = &HDC00 '<--- Constant used in conversion from unicode to UTF16 Code Units
Dim highSurrogate As Long, lowSurrogate As Long
Select Case Unicode
Case Is < LOWEST_UNICODE, Is > HIGHEST_UNICODE
' Input Code is not in unicode range, return null string
ChrWW = vbNullString
Case Is < SUPPLEMENTARY_UNICODE
' Input Code is within range of native VBA function ChrW, so use that instead
ChrWW = ChrW(Unicode)
Case Else
' Code is on Supplementary Planes, convert to two UTF-16 code units and convert to text using ChrW
highSurrogate = HIGH_SURROGATE_CONST + ((Unicode - SUPPLEMENTARY_UNICODE) \ TEN_BITS)
lowSurrogate = LOW_SURROGATE_CONST + ((Unicode - SUPPLEMENTARY_UNICODE) Mod TEN_BITS)
ChrWW = ChrW(highSurrogate) & ChrW(lowSurrogate)
End Select
End Function
Для справки о используемых символах юникода см. здесь http://www.fileformat.info/info/unicode/block/mathematical_alphanumeric_symbols/list.htm
На странице wikipedia на UTF16 показан алгоритм преобразования из Юникода в две кодовые точки UTF16
Как уже говорилось, вы не можете форматировать значение частичной ячейки, если это последнее происходит от формулы/функции в той же ячейке
Однако могут быть некоторые обходные пути, которые могут удовлетворить ваши потребности.
К несчастью, я не могу понять вашу настоящую среду, поэтому вот несколько слепых снимков:
1-я "среда"
У вас есть код VBA, который в какой-то момент записывает в ячейку, например:
Cells(5, 1).Formula = "=""Dealer: "" & CustomerName"
и вы хотите, чтобы часть "Dealer:" выделена жирным шрифтом
самым простым способом было бы
With Cells(5, 1)
.Formula = "=""Dealer: "" & CustomerName"
.Value = .Value
.Characters(1, 7).Font.Bold = True
End With
но вы также можете использовать обработчик событий Worksheet_Change() следующим образом:
ваш код VBA находится только
Cells(5, 1).Formula = "=""Dealer: "" & CustomerName"
поместив следующий код в соответствующую область кода рабочего листа:
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If Left(.Text, 7) = "Dealer:" Then
Application.EnableEvents = False '<-- prevent this macro to be fired again and again by the statement following in two rows
On Error GoTo ExitSub
.Value = .Value
.Characters(1, 7).Font.Bold = True
End If
End With
ExitSub:
Application.EnableEvents = True '<-- get standard event handling back
End Sub
где On Error GoTo ExitSub и ExitSub: Application.EnableEvents = True не должны быть необходимы, но я оставил их в качестве хорошей практики, когда используется Application.EnableEvents = False id
Вторая "среда"
У вас есть ячейка на вашем листе excel, содержащем формулу, например:
="Dealer:" & CustomerName
где CustomerName - именованный диапазон
и ваш код VBA будет изменять содержимое этого именованного диапазона
в этом случае sub Worksheet_Change() будет вызван изменением значения именованного диапазона, а не ячейкой, содержащей формулу
поэтому я бы посмотрел, является ли измененная ячейка valid одной (то есть соответствующей well known именованному диапазону), а затем перейдет с поднабором, который сканирует предопределенный диапазон и находит и форматирует все ячейки с формулами, которые используйте "named range", например, следующие (комментарии должны вам помочь):
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If Not Intersect(ActiveWorkbook.Names("CustomerName").RefersToRange, Target) Is Nothing Then
Application.EnableEvents = False '<-- prevent this macro to be fired again and again by the statement following in two rows
On Error GoTo ExitSub
FormatCells Columns(1), "CustomerName" '<-- call a specific sub that will properly format all cells of passed range that contains reference to passed "named range" name
End If
End With
ExitSub:
Application.EnableEvents = True '<-- get standard event handling back
End Sub
Sub FormatCells(rng As Range, strngInFormula As String)
Dim f As Range
Dim firstAddress As String
With rng.SpecialCells(xlCellTypeFormulas) '<--| reference passed range cells containg formulas only
Set f = .Find(what:=strngInFormula, LookIn:=xlFormulas, lookat:=xlPart) '<--| search for the first cell in the referenced range containing the passed formula part
If Not f Is Nothing Then '<--| if found
firstAddress = f.Address '<--| store first found cell address
Do '<--| start looping through all possible matching criteria cells
f.Value = f.Value '<--| change current cell content into text resulting from its formula
f.Characters(1, 7).Font.Bold = True '<--| make its first 7 characters bold
Set f = .FindNext(f) '<--| search for next matching cell
Loop While f.Address <> firstAddress '<--| exit loop before 'Find()' method wraps back to the first cell found
End If
End With
End Sub
Требования:
Я понимаю, что OP должен иметь в ячейке A5 результат формулы ="Dealer: " & CustomerName, показывающий часть Dealer: жирным шрифтом.
Теперь, что неясно, есть природа части CustomerName формулы. Это решение предполагает, что оно соответствует Defined Name с объемом рабочей книги (дайте мне знать, если оно отличается).
Я предполагаю, что причина использования формулы и не написание непосредственно результата формулы и форматирование ячейки A5 с помощью процедуры VBA - это позволить пользователям видеть данные от разных клиентов только путем изменения калькуляции в рабочей книги, а не путем выполнения процедуры VBA.
Скажем, что у нас есть следующие данные на листе с именем Report, были ли у Defined Name CustomerName область рабочей книги и она скрыта.
В A5 находится формула ="Dealer: " & CustomerName
На рисунке 1 показан отчет с данными для Customer 1.
Рис .1
Теперь, если мы изменим номер клиента в ячейке E3 на 4, в отчете будут отображены данные выбранного клиента; без выполнения какой-либо процедуры VBA. К сожалению, поскольку ячейка A5 содержит формулу, ее шрифт содержимого не может быть частично отформатирован, чтобы отобразить "Дилер:" жирным шрифтом. На рисунке 2 показан отчет с данными для Customer 4.
Рис .2
Предлагаемое здесь решение - Динамически отображать содержимое ячейки или диапазона в графическом объекте
Чтобы реализовать это решение, нам нужно воссоздать желаемый выходной диапазон и добавить Shape в A5, который будет содержать ссылку на выходной диапазон.
Предполагая, что мы не хотим, чтобы этот выходной диапазон отображался на том же рабочем листе, был отчет, и не забывайте, что ячейки выходного диапазона нельзя скрыть; позволяет создать этот выходной диапазон на другом листе с именем "Данные клиентов" в B2:C3 (см. рис. 3). Введите B2 Dealer: в C2 и введите C2 формулу =Customer Name, затем отформатируйте каждую ячейку по мере необходимости (B2 font bold, C3 может иметь другой тип шрифта, если хотите - позволяет применять шрифт курсивом для этот образец). Убедитесь, что диапазон имеет соответствующую ширину, поэтому текст не переполняет ячейки.
Рис .3
Он предложил создать Defined Name для этого диапазона. Код ниже создает Defined Name, называемый RptDealer.
Const kRptDealer As String = "RptDealer" ‘Have this constant at the top of the Module. It is use by two procedures
Sub Name_ReportDealerName_Add()
'Change Sheetname "Customers Data" and Range "B2:C2" as required
With ThisWorkbook.Sheets("Customers Data")
.Cells(2, 2).Value = "Dealer: "
.Cells(2, 2).Font.Bold = True
.Cells(2, 3).Formula = "=CustomerName" 'Change as required
.Cells(2, 3).Font.Italic = True
With .Parent
.Names.Add Name:=kRptDealer, RefersTo:=.Sheets("Customers Data").Range("B2:C2") ', _
Visible:=False 'Visible is True by Default, use False want to have the Name hidden to users
.Names(kRptDealer).Comment = "Name use for Dealer\Customer picture in report"
End With
.Range(kRptDealer).Columns.AutoFit
End With
End Sub
Следуя вышеприведенным приготовлениям, теперь мы можем создать форму, которая будет связана с диапазоном вывода с именем RptDealer. Выберите в ячейке A5 в листе Report и следуйте инструкциям для Динамически отображать содержимое ячейки на картинке или если вы предпочитаете использовать код ниже, чтобы добавить и отформатировать связанный Shape.
Sub Shape_DealerPicture_Set(rCll As Range)
Const kShpName As String = "_ShpDealer"
Dim rSrc As Range
Dim shpTrg As Shape
Rem Delete Dealer Shape if present and set Dealer Source Range
On Error Resume Next
rCll.Worksheet.Shapes(kShpName).Delete
On Error GoTo 0
Rem Set Dealer Source Range
Set rSrc = ThisWorkbook.Names(kRptDealer).RefersToRange
Rem Target Cell Settings & Add Picture Shape
With rCll
.ClearContents
If .RowHeight < rSrc.RowHeight Then .RowHeight = rSrc.RowHeight
If .ColumnWidth < rSrc.Cells(1).ColumnWidth + rSrc.Cells(2).ColumnWidth Then _
.ColumnWidth = rSrc.Cells(1).ColumnWidth + rSrc.Cells(2).ColumnWidth
rSrc.CopyPicture
.PasteSpecial
Selection.Formula = rSrc.Address(External:=1)
Selection.PrintObject = msoTrue
Application.CutCopyMode = False
Application.Goto .Cells(1)
Set shpTrg = .Worksheet.Shapes(.Worksheet.Shapes.Count)
End With
Rem Shape Settings
With shpTrg
On Error Resume Next
.Name = "_ShpDealer"
On Error GoTo 0
.Locked = msoFalse
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
.LockAspectRatio = msoTrue
.Placement = xlMoveAndSize
.Locked = msoTrue
End With
End Sub
Вышеупомянутый код можно вызвать с помощью этой процедуры:
Sub DealerPicture_Apply()
Dim rCll As Range
Set rCll = ThisWorkbook.Sheets("Report").Cells(5, 1)
Call Shape_DealerPicture_Set(rCll)
End Sub
Конечным результатом является изображение, которое ведет себя как формула, поскольку оно связано с выходным диапазоном, содержащим требуемую формулу и формат (см. рис. 4).
Рис .4
Вместо ссылки вы можете просто получить ячейки и поместить их в переменную и в основном добавить ее. Отсюда вы можете использовать функциональность .font.bold, чтобы выделить выделенную часть. Допустим, на стр. 2 у вас есть "Дилер:" в ячейке a1 и "Джош" в b1. Вот пример того, как это можно сделать:
Worksheets("Sheet1").Cells(5, "a") = Worksheets("Sheet2").Cells(1, "a") & Worksheets("Sheet1").Cells(1, "b")
Worksheets("Sheet1").Cells(5, "a").Characters(1, 7).Font.Bold = True 'Bolds "dealer:" only.
Здесь моя попытка решить подобную, но другую проблему, чем опубликованная OP. Я думаю, что решение Mark R, вероятно, лучше всего подходит для поставленного вопроса, однако я решил поделиться решением, поскольку оно связано с обсуждением здесь.
Я нахожу действительно раздражающим в Excel, чтобы вернуться и отформатировать определенное слово в ячейке для какой-то спецификации. Например. слово "Управление" должно быть полужирным для каждого экземпляра определенного диапазона. Или добавление суб/надстрочного знака, прокрутки и т.д.
Итак, я написал этот Sub, чтобы немного изменить формат во многих ячейках.
Скажем, у нас есть следующая книга:
Мы хотим заменить каждый экземпляр "StackOverflow" и "онлайн" в столбце E форматированием в столбце A. Следующий код будет выполнять эти изменения формата.
Option Explicit
Option Compare Text
Public Sub UpdateFormat(LookInRange As Range, _
LookForRange As Range, _
Optional SearchLeftToRight As Boolean = True, _
Optional NumberToFormat As Integer = 0)
On Error GoTo ErrHand
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim MyCell As Range
Dim StrCell As Range
Dim StrLength As Integer
Dim FoundPos As Integer
Dim StartPos As Integer
Dim FormatCounter As Integer
Dim ErrorMsg As String: ErrorMsg = "You have missed the following information:" & vbCrLf & vbCrLf
Dim retval
'Error checking
If LookInRange Is Nothing Then ErrorMsg = ErrorMsg & "There are no cells with text in the LookInRange" & vbCrLf
If LookForRange Is Nothing Then ErrorMsg = ErrorMsg & "There are no cells with text in the StrRange" & vbCrLf
'Display a message if something is missed and exit
If ErrorMsg <> "You have missed the following information:" & vbCrLf & vbCrLf Then
MsgBox (ErrorMsg)
Exit Sub
End If
For Each MyCell In LookInRange
For Each StrCell In LookForRange
StrLength = Len(StrCell)
If SearchLeftToRight Then StartPos = 1 Else: StartPos = Len(MyCell.Value)
'Determine the found position
FoundPos = getPosition(MyCell, StartPos, SearchLeftToRight, StrCell.Value)
FormatCounter = 0 ' This is used to process track how many instances of format alterations -
', entering NumberFormat=0 means format all instances
Do While FoundPos > 0
'Format the text, match the format with the LookForRange cells
With StrCell.Font
MyCell.Characters(FoundPos, StrLength).Font.Bold = .Bold
MyCell.Characters(FoundPos, StrLength).Font.Italic = .Italic
MyCell.Characters(FoundPos, StrLength).Font.Underline = .Underline
MyCell.Characters(FoundPos, StrLength).Font.Color = .Color
MyCell.Characters(FoundPos, StrLength).Font.Strikethrough = .Strikethrough
MyCell.Characters(FoundPos, StrLength).Font.Superscript = .Superscript
MyCell.Characters(FoundPos, StrLength).Font.Subscript = .Subscript
MyCell.Characters(FoundPos, StrLength).Font.Name = .Name
MyCell.Characters(FoundPos, StrLength).Font.Size = .Size
End With
'Get new Position, allow for forward and backward searching
If SearchLeftToRight Then StartPos = StrLength + FoundPos Else: StartPos = FoundPos
FoundPos = getPosition(MyCell, StartPos, SearchLeftToRight, StrCell.Value)
'Exit/Number of formats
If NumberToFormat > 0 Then FormatCounter = FormatCounter + 1
If FormatCounter = NumberToFormat And NumberToFormat <> 0 Then Exit Do
Loop
Next
Next
'Clean Up
Set LookInRange = Nothing
Set LookForRange = Nothing
Set MyCell = Nothing
Set StrCell = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
ErrHand:
Application.ScreenUpdating = True
Application.EnableEvents = True
retval = MsgBox(Err.Number & " " & Err.Description, vbCritical, "Error!")
End Sub
Function getPosition(ByVal MyRng As Range, _
ByVal StartPos As Integer, _
ByVal SearchLeftToRight As Boolean, _
ByVal StrToFind As String) As Integer
If SearchLeftToRight Then
getPosition = InStr(StartPos, MyRng.Value, StrToFind)
Else
getPosition = InStrRev(MyRng.Value, StrToFind, StartPos)
End If
End Function
Sub Test()
'Parameter 1: Range Type.
'Where to Look for text replacements
'Parameter 2: Range Type.
'The Range containing the text and format of the text to replace
'Optional Parameter 3: Boolean Type.
'Search from Left to Right, set True (Default). To Search Right to left, set as False
'Optional Parameter 4: Integer Type.
'How many format alterations should be processed per cell, Default is 0 which is all instances
'Call the UpdateFormat Sub
UpdateFormat Range("E1:E100"), Range("A1:A2")
End Sub
Вот результат после запуска кода:
Код изменит свойства Bold, Italic, Underline, Font, Size, Color, SuperScript и SubScript, чтобы они соответствовали значениям в столбце A. Я добавил некоторые другие функции в подпрограмму, такие как обработка только определенного количества изменений формата на ячейку. Например, если вы хотите заменить только первый найденный экземпляр определенного слова в ячейке, вы можете вызвать подпрограмму следующим образом:
UpdateFormat Range("E1:E100"), Range("A1:A2"),, 1
Кроме того, вы можете искать в обратном порядке, если хотите заменить, скажем, последний экземпляр слова.
UpdateFormat Range("E1:E100"), Range("A1:A2"), False, 1
Я надеюсь, что это поможет кому-то!