Macro para unificar los formatos en un Manual

Entendiendo que todos los apartados en algún punto se relacionan entre si, que necesitaba unificar formatos, estilos y formas de presentación surgió la siguiente aplicación con el objetivo de estandarizar lo escrito, y resaltar lo importante.

Objetivo: Cada vez que modifique o escriba en una celda, esta macro se ejecutará de manera automática dirigiéndose a verificar palabra por palabra que exista dentro del MC_ANX_01, Abreviaturas y Definiciones. Cuando la confirmación sea positiva la macro resaltará en el texto por ejemplo:

Con color Rojo y en cursiva la palabra que refiera a:

• Un Formulario
• Un Procedimiento General
• Un Manual

Con Color Azul y en cursiva la palabra que refiera a:

• Un Documento Externo
• Un Registro
• Un Registro Tentativo

Con Color Violeta y en cursiva la palabra que Refiera a:

• Definiciones
• Abreviaturas
• Lugares
• Personas

Public Sub Resalta(Celda As Range, Hoja As String)
Application.ScreenUpdating = False
Selection.Font.Italic = True
Selection.Font.Italic = False
Selection.Font.Bold = True
Selection.Font.Bold = False
Selection.Font.ThemeColor = xlThemeColorLight1
Selection.Font.TintAndShade = 0
If Celda.Count > 1 Then Celda = Celda(1)
If Celda.HasFormula = True Then
    Celda.Font.Name = "Courrier New"
    Celda.Font.COlor = 255
    Application.ScreenUpdating = True
    Exit Sub
End If
If Not Celda.Interior.ColorIndex = -4142 Then Exit Sub
Dim Bcle As Long
Dim Resalta As String
Dim Start As Long:
Dim COlor As Long
Dim Rojo As Long: Rojo = 255
Dim Verde As Long: Verde = 5287936
Dim Azul As Long: Azul = 8210719
Dim Violeta As Long: Violeta = 10498160
Dim Naranja As Long: Naranja = 49407
Dim Pto As Long
Dim limite_hoja As Long
Dim Sh As String: Sh = "MC-ANX_01"
limite_hoja = Excel.Sheets(Sh).Range("A65536").End(xlUp).Row
Dim Find As Variant: Find = Excel.Sheets(Sh).Range(Excel.Sheets(Sh).Cells(9, 1), Excel.Sheets(Sh).Cells(limite_hoja, 40)).Value
Dim Sh_RD As String: Sh_RD = "S-PG-01"
limite_hoja = Excel.Sheets(Sh_RD).Range("A65536").End(xlUp).Row
Dim Find_RD As Variant: Find_RD = Excel.Sheets(Sh_RD).Range(Excel.Sheets(Sh_RD).Cells(11, 1), Excel.Sheets(Sh_RD).Cells(limite_hoja, 11)).Value
On Error Resume Next
For Bcle = 1 To UBound(Find)
    If Not Find(Bcle, 7) = "" Then
        Resalta = Find(Bcle, 7)
        Select Case Find(Bcle, 3)
            Case "Definiciones": COlor = Violeta
            Case "Abreviatura": COlor = Violeta
            Case "Lugares": COlor = Violeta
            Case "Personas": COlor = Violeta
        End Select
        Pto = 0
Insiste:
        On Error Resume Next
        Pto = InStr(Pto + 1, UCase(Celda(1)), UCase(Resalta))
        If Pto > 1 Then
            With ActiveCell.Characters(Start:=Pto, Length:=Len(Resalta)).Font
                .FontStyle = "Cursiva"
                .COlor = COlor
            End With
        If InStr(Pto, UCase(Celda(1)), UCase(Resalta)) > 1 Then Pto = InStr(Pto, UCase(Celda(1)), UCase(Resalta)): GoTo Insiste:
        End If
    End If
Next
For Bcle = 1 To UBound(Find_RD)
        Resalta = Find_RD(Bcle, 6) & ", " & Find_RD(Bcle, 11)
        If Resalta = ", " Then GoTo Salta:
        Select Case Find_RD(Bcle, 1)
            Case "Formulario": COlor = Rojo
            Case "Proc. General": COlor = Rojo
            Case "Manual": COlor = Rojo
            Case "Doc. Ext.": COlor = Azul
            Case "Registro": COlor = Azul
            Case "Registro tentativo": COlor = Azul
        End Select
        Pto = 0
Insiste2:
        On Error Resume Next
        Pto = InStr(Pto + 1, UCase(Celda(1)), UCase(Resalta))
        If Pto > 1 And Len(Celda(1)) > 1 Then
            With ActiveCell.Characters(Start:=Pto, Length:=Len(Resalta)).Font
                .FontStyle = "Negrita Cursiva"
                .COlor = COlor
            End With
        If InStr(Pto, UCase(Celda(1)), UCase(Resalta)) > 1 Then Pto = InStr(Pto, UCase(Celda(1)), UCase(Resalta)): GoTo Insiste2:
        End If
Salta:
Next
Application.ScreenUpdating = True
End Sub

Si te interesa dale al botón G+, comenta, participa...

Y escribime para enviarte el ejemplo!