Выделение выделенной части ячейки

Ответ 1

Вы можете использовать приведенную ниже функцию, чтобы полужирный текст ввода внутри формулы

Итак, в вашей ячейке теперь вы можете ввести = 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

https://en.wikipedia.org/wiki/UTF-16

Ответ 2

Как уже говорилось, вы не можете форматировать значение частичной ячейки, если это последнее происходит от формулы/функции в той же ячейке

Однако могут быть некоторые обходные пути, которые могут удовлетворить ваши потребности.

К несчастью, я не могу понять вашу настоящую среду, поэтому вот несколько слепых снимков:

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

Ответ 3

Требования:

Я понимаю, что 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

Ответ 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.

Ответ 5

Здесь моя попытка решить подобную, но другую проблему, чем опубликованная 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

Я надеюсь, что это поможет кому-то!