Macro para aplicar Formato Negrita, Cursiva, Subrayado, Subrayado Doble a determinadas palabras en una concatenación en Excel

Código

Sub IB·AplicarFormato()

Dim R As Range, B As Range, C As Range, E As Variant

Dim t As String, v As Range, w As String, x As Range, y As Variant, z As Variant, I As Long

On Error Resume Next

Set R = Application.InputBox("Seleccione el rango donde se dará formato a las palabras:", "INGENIERÍA & BURÓTICA", , Type:=8)

On Error GoTo 0

If R Is Nothing Then Exit Sub

On Error Resume Next

Set B = Application.InputBox("Seleccione el rango con las palabras a las que se dará formato:", "INGENIERÍA & BURÓTICA", Type:=8)

On Error GoTo 0

If B Is Nothing Then Exit Sub

E = Split(Replace(Trim(UCase(InputBox("Ingrese los códigos de formato separados por comas (N para negrita, K para cursiva, S para subrayado, D para subrayado doble):", "INGENIERÍA & BURÓTICA"))), " ", ""), ",")

y = Array("N", "K", "S", "D")

For Each z In E

If Not IsError(Application.Match(z, y, 0)) Then

Select Case z

Case "N"

For Each C In R

For Each x In B

t = x.Value

Set v = C.Cells.Find(What:=t, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)

If Not v Is Nothing Then

w = v.Address

Do

v.Characters(Start:=InStr(1, v.Value, t), Length:=Len(t)).Font.Bold = True

Set v = C.Cells.FindNext(v)

Loop While Not v Is Nothing And v.Address <> w

End If

Next x

Next C

Case "K"

For Each C In R

For Each x In B

t = x.Value

Set v = C.Cells.Find(What:=t, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)

If Not v Is Nothing Then

w = v.Address

Do

v.Characters(Start:=InStr(1, v.Value, t), Length:=Len(t)).Font.Italic = True

Set v = C.Cells.FindNext(v)

Loop While Not v Is Nothing And v.Address <> w

End If

Next x

Next C

Case "S"

For Each C In R

For Each x In B

t = x.Value

Set v = C.Cells.Find(What:=t, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)

If Not v Is Nothing Then

w = v.Address

Do

v.Characters(Start:=InStr(1, v.Value, t), Length:=Len(t)).Font.Underline = xlUnderlineStyleSingle

Set v = C.Cells.FindNext(v)

Loop While Not v Is Nothing And v.Address <> w

End If

Next x

Next C

Case "D"

For Each C In R

For Each x In B

t = x.Value

Set v = C.Cells.Find(What:=t, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)

If Not v Is Nothing Then

w = v.Address

Do

v.Characters(Start:=InStr(1, v.Value, t), Length:=Len(t)).Font.Underline = xlUnderlineStyleDouble

Set v = C.Cells.FindNext(v)

Loop While Not v Is Nothing And v.Address <> w

End If

Next x

Next C

End Select

End If

Next z

MsgBox "Formato de palabras completado.", , "INGENIERÍA & BURÓTICA"

End Sub