加固细胞的特定部分

我有一个单元格引用为="Dealer: " & CustomerName 。 CustomerName是一个字典引用的名字。 我怎么能只用“加工商”而不是客户的名字。

例：

经销商：乔希

我努力了

 Cells(5, 1).Characters(1, 7).Font.Bold = True 

但它似乎只能在未引用的单元格上工作。 我怎么能得到这个工作在一个参考单元格？

Answer 1

您可以使用下面的函数在公式中加粗某些input文本

因此，在您的单元格中，您现在可以input= Bold（“Dealer：”）＆CustomerName

确切地说 – 这只会刺激字母字符（a到z和A到Z），所有其他字母都将保持不变。 我没有在不同的平台上testing，但似乎在我的工作。 可能不支持所有字体。

  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 

编辑：

已经努力重构上面的内容来展示它是如何工作的，而不是用不可思议的数字。

  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 

有关unicode字符的参考，请参阅http://www.fileformat.info/info/unicode/block/mathematical_alphanumeric_symbols/list.htm

UTF16上的维基百科页面显示了从Unicode转换为两个UTF16编码点的algorithm

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

Answer 2

正如他们已经告诉过的，如果后者从同一单元格中的公式/函数派生出来，则不能格式化部分单元格值

但是可能有一些解决方法可能适合您的需求

不幸的是我实际上无法掌握你的真实环境，所以下面是一些盲目的镜头：

---

第一“环境”

你有一个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 used

---

第二“环境”

您的Excel工作表中包含一个或多个单元格，其中包含一个公式，例如：

 ="Dealer:" & CustomerName 

其中CustomerName是命名的范围

而你的VBA代码将会修改这个指定范围的内容

在这种情况下， Worksheet_Change()子将由命名的范围值更改触发，而不是由包含公式的单元格

所以我会去检查被更改的单元格是否是valid单元格（即，对应于well known命名范围），然后使用扫描预定义范围的子单元格，并使用该命名范围的公式来查找和格式化所有单元格，如下（评论应该帮助你）：

 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 

Answer 3

要求：

我的理解是OP需要在单元格A5中具有公式="Dealer: " & CustomerName以粗体字显示Dealer:部分。 现在，不清楚的是公式的CustomerName部分的性质。 此解决scheme假定它对应于具有工作簿范围的Defined Name （如果不同，请告诉我） 。

我假定使用公式的原因，而不是直接写公式的结果，并用VBA程序格式化A5单元格的原因是允许用户通过工作簿中的计算更改来查看来自不同客户的数据，而不是运行一个VBA程序。

假设我们在一个名为Report的工作表中有以下数据，那么定义名称CustomerName具有工作簿范围并且是隐藏的。 A5位于公式="Dealer: " & CustomerName图1显示了Customer 1的数据报告。

图。1

现在，如果我们将单元格E3的客户编号更改为4 ，则报表将显示所选客户的数据; 而不运行任何VBA程序。 不幸的是，单元格A5包含一个公式，其内容字体不能部分格式化，以粗体字显示“经销商：”。 图2显示了Customer 4的数据报告。

图2

此处提出的解决scheme是dynamic显示graphics对象中单元格或区域的内容

为了实现这个解决scheme，我们需要重新创build所需的输出范围，并在A5中添加一个包含到输出范围的链接的Shape 。 假设我们不希望在同一个工作表中看到这个输出范围，报告是，并且要记住， 输出范围单元不能被隐藏 ; 让我们在B2:C3另一个名为“Customers Data”的工作表中创build这个输出范围（参见图3）。 在B2 Dealer:inputDealer:并在C2input公式=Customer Name然后根据需要格式化每个单元格（ B2字体粗体，如果喜欢， C3可以使用不同的字体types – 让我们将字体斜体应用于此示例）。 确保范围具有适当的宽度，以便文本不会溢出单元格。

图3

build议为该范围创build一个Defined Name 。 下面的代码创build了名为RptDealer的Defined Name 。

 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 

按照上面的准备工作，现在我们可以创build一个与名为RptDealer的输出范围相连的形状。 在工作表Report单元格A5处select，然后按照说明在图片中dynamic显示单元格区域内容，或者如果您愿意使用下面的代码添加和格式化链接的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

Answer 4

您可以简单地获取单元格并将其放置在一个variables中，而不是引用您可以简单地追加它。 从这里您可以使用.font.boldfunction来粗体显示特定的部分。 让我们说第二页，在单元格a1中有“Dealer：”，在b1中有“Josh”。 这是一个如何完成的例子：

 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. 

Answer 5

以下是我尝试解决与OP发布相似但不同的问题。 我认为马克R的解决scheme可能是最好的，但我认为我会分享一个解决scheme，因为它与这里的讨论有关。

在Excel中，我发现真的很烦人，回到格式化单元格中的某个特定的单词。 例如，对于特定范围内的每个实例，“pipe理”一词应该是粗体的。 或者添加子标，标号等。

所以我写了这个Sub来更改一些单元格的格式。

假设我们有以下工作簿：

我们想用列A中的格式replace列E中的“StackOverflow”和“online”的每个实例。以下代码将执行这些格式更改。

 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 

这是运行代码后的结果：

代码将更改粗体，斜体，下划线，字体，大小，颜色，SuperScript和SubScript属性以匹配A列中的那些属性。我在子例程中添加了一些其他function，例如每个单元格只处理特定数量的格式更改。 例如，如果您只想replace单元格中特定单词的第一个find的实例，则可以像这样调用子例程：

UpdateFormat Range("E1:E100"), Range("A1:A2"),, 1

另外，如果要replace单词的最后一个实例，则可以反向search。

UpdateFormat Range("E1:E100"), Range("A1:A2"), False, 1

我希望它可以帮助别人！