Macro para aplicar negrita en texto concatenado en rango fijo en Excel
Código para Rango Fijo
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, ) Is Nothing Then
Dim o As Range, R As Range, B As Range, C As Range
Dim celdaActiva As Range
Set o = Range("")
Set R = Range("")
Set B = Range("")
Set celdaActiva = ActiveCell
Application.EnableEvents = False
R.Value = o.Value
For Each C In R
C.Font.Bold = False
For Each bCell In B
If InStr(1, C.Text, bCell.Value) > 0 Then
posInicial = InStr(1, C.Text, bCell.Value)
longitud = Len(bCell.Value)
C.Characters(posInicial, longitud).Font.Bold = True
End If
Next bCell
Next C
Application.EnableEvents = True
If Not celdaActiva Is Nothing Then celdaActiva.Select
End If
End Sub
Código para Rango Dinámico
...
codigo para que no solo cambie a la primera palabra encontrada sino a todas
ResponderEliminarPrivate Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("E3:E5")) Is Nothing Then
Dim o As Range, R As Range, B As Range, C As Range
Dim palabra As Variant
Dim celdaActiva As Range
Set o = Range("E18:E22") ' Rango con los datos concatenados
Set R = Range("A18:A22") ' Rango resultado
Set B = Range("E2:E5") ' Rango con las palabras que se pondrán en negrita
Set celdaActiva = ActiveCell
Application.EnableEvents = False
R.Value = o.Value
For Each C In R
C.Font.Bold = False
For Each palabra In Split(C.Text) ' Separar la concatenación en palabras
For Each bCell In B
If palabra = bCell.Value Then
posInicial = 1
Do While posInicial > 0 ' Continuar buscando la palabra en la celda
posInicial = InStr(posInicial, C.Text, palabra)
If posInicial > 0 Then
longitud = Len(palabra)
C.Characters(posInicial, longitud).Font.Bold = True
posInicial = posInicial + longitud ' Mover la posición de inicio después de la última ocurrencia
End If
Loop
End If
Next bCell
Next palabra
Next C
Application.EnableEvents = True
If Not celdaActiva Is Nothing Then celdaActiva.Select
End If
End Sub