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, j As Range, o As String, x As Range, g As Variant, m As Variant

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"))), " ", ""), ",")

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

For Each m In E

If Not IsError(Application.Match(m, g, 0)) Then

Select Case m

Case "N"

For Each C In R

For Each x In B

t = x.Value

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

If Not j Is Nothing Then

o = j.Address

Do

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

Set j = C.Cells.FindNext(j)

Loop While Not j Is Nothing And j.Address <> o

End If

Next x

Next C

Case "K"

For Each C In R

For Each x In B

t = x.Value

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

If Not j Is Nothing Then

o = j.Address

Do

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

Set j = C.Cells.FindNext(j)

Loop While Not j Is Nothing And j.Address <> o

End If

Next x

Next C

Case "S"

For Each C In R

For Each x In B

t = x.Value

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

If Not j Is Nothing Then

o = j.Address

Do

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

Set j = C.Cells.FindNext(j)

Loop While Not j Is Nothing And j.Address <> o

End If

Next x

Next C

Case "D"

For Each C In R

For Each x In B

t = x.Value

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

If Not j Is Nothing Then

o = j.Address

Do

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

Set j = C.Cells.FindNext(j)

Loop While Not j Is Nothing And j.Address <> o

End If

Next x

Next C

End Select

End If

Next m

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

End Sub