Imprimir
Categoría: Uncategorised
Visto: 51967

Mis Macros Favoritas

 

Creado por Héctor Miguel Orozco Díaz

 

En este artículo os vamos a mostrar:

¿Cómo podéis crear una barra de herramientas que sea válida para todas las versiones de Office Excel?. 

Paquete de macros: 

  1. convertir [may/min]usculas- Frase u Oración, bien en una celda o en toda la hoja.
  2. convertir [may/min]usculas  
    • Frase u Oración como en MS Word [shift + F3]
    • Listar nuestras hojas y navegar con ellas con un tan solo Click -Ordenar las hojas sin importar si son [may/min]o bien distinguiéndolas
    • Entorno
    • Botón Terminar
  3. tres funciones incluidas en el archivo y una nueva manera de Registrarlas:  

 

Desarrollo Mis Macros Favoritas

 

Como muchos de vosotros sabeis, la nueva interfaz de Office Excel 2007 está realizada con los nuevos formatos XML de código abierto. Como su nombre indica XML ( Xtensible Markup Languaje ) ...traducido (lenguaje extensible de marcas) y que con este nuevo uso de XML en Office 2007 nos permite adaptar la nueva Interfaz agregando nuevas Etiquetas, grupo de botones, combobox y un largo etc....

Para crear la barra de herramientas, hay que seguir los siguientes pasos:

        1. Crear un archivo de Excel llamado: [ mis Macros Favoritas.xls ]: En el situaremos el código  para crear la barra de herramientas compatible para versiones de Office 97 a la 2003.
        2. Crear un Complemento en Excel 2007 llamado:  [ mis Macros en la Cinta.xlam ]: En el situaremos el código XML para crear la Cinta Ribbon en Excel 2007 y versiones posteriores.
        3. Guardar siempre JUNTOS los dos archivos en una misma carpeta que la podéis llamar como querais.   OjO muy importante... se deben guardar ambos archivos JUNTOS en un mismo directorio ya que cada uno necesita del otro además de NO modificarl os códigos que en el archivo [ mis Macros Favoritas.xls ] aparecen, SOBRE TODO si no entendeis ni de XML ni de Programacion VBA.

Cuando necesitemos nuestras barras de herramientas tanto para una versión como para otra, simplemente desde cualquier archivo de Excel Abierto, le damos a abrir [ mis Macros Favoritas. xls].

El código que se ha utilizado es el siguiente:

Option Private Module
Private Const Botones As String = "(May/min)usculas,Mayusculas,Minusculas,Nombre propio,Tipo frase,Como MS-Word {Alt}+{F3},Seleccionar hoja,Ordenar hojas,Ordenar hojas M,Entorno,Salir"
Private Const Macros As String = "'Capitaliza 0','Capitaliza 1','Capitaliza 2','Capitaliza 3','Capitaliza 4',CapitalizaComoWord,ListaHojas,OrdenaHojas,OrdenaHojasM,AveriguaMiEntorno,Terminar"
Private Const Imagenes As String = "401,403,404,476,289,42,304,312,461,487,644": Private Const Grupos As String = "0,0,0,0,0,0,1,1,0,1,1"
Public Const Office12 As String = "mis Macros en la Cinta.xlam": Public Const misMacros As String = "mis Macros Favoritas"
Public Cinta As Boolean, BarraInstalada As Boolean, Cerrando As Boolean
Sub Agrega_miBarra(): Elimina_miBarra: Dim Boton, Macro, Imagen, Grupo, n As Byte
  Boton = Split(Botones, ","): Macro = Split(Macros, ",")
  Imagen = Split(Imagenes, ","): Grupo = Split(Grupos, ",")
  With Application.CommandBars.Add(misMacros, msoBarFloating, False, True)
    For n = LBound(Boton) To UBound(Boton)
      With .Controls.Add(Type:=msoControlButton, Temporary:=True)
        .BeginGroup = Grupo(n): .Caption = Boton(n): .OnAction = Macro(n): .FaceId = Imagen(n)
      End With: Next: .Visible = True: End With: BarraInstalada = True: End Sub
Sub Elimina_miBarra(): On Error Resume Next: Application.CommandBars(misMacros).Delete: End Sub
Sub MisMacrosEnLaCinta(): If ThisWorkbook.Name = misMacros & ".xls" Then GoTo Cinta
  If MsgBox("Has cambiado el nombre de este archivo <\?|?/>" & vbCr & _
    "Las macros en la Cinta de Opciones NO FUNCIONARAN !!!" & vbCr & _
    "Si deseas que funcionen las macros desde Cinta de Opciones..." & vbCr & _
    "DEBERAS ""regresarle"" su nombre original de: " & misMacros & ".xls" & vbCr & vbCr & _
    "Deseas instalar una barra de herramientas en la ficha ""Complementos"" ?", _
    vbCritical + vbYesNo + vbDefaultButton2, "Instalando herramientas !!!") = _
    vbYes Then Agrega_miBarra: Exit Sub
Cinta:
  If Dir(ThisWorkbook.Path & "\" & Office12) <> "" _
    Then Workbooks.Open ThisWorkbook.Path & "\" & Office12: Exit Sub
  If MsgBox("Se requiere el archivo " & Office12 & vbCr & _
    "NO esta presente para instalar las macros en la Cinta de Opciones !!!" & vbCr & _
    "Deseas instalar una barra de herramientas en la ficha ""Complementos"" ?", _
    vbQuestion + vbYesNo + vbDefaultButton2, "Instalando: mis Macros Favoritas !!!") = _
    vbYes Then Agrega_miBarra
End Sub
Sub TerminaSesion(): On Error Resume Next: Workbooks(Office12).Close False: End Sub

 

Sub RegistraFunciones(Registro As Boolean)
  With Application
    .MacroOptions Macro:="AF_Activo", Category:=9, Description:= _
      "Devuelve Verdadero/Falso si la referencia especificada tiene activados los AutoFiltros" & vbCr & _
      "El argumento ""Ref"" DEBE SER una referencia de celda." & vbCr & _
      "Otros argumentos como sean requeridos." & vbCr & _
      "Tercera y cuarta lineas se muestran (solo) en el dialogo ""Pegar funcion""."
    .MacroOptions Macro:="Concatenado", Category:=7, Description:= _
      "Devuelve la ""concatenacion"" de los datos en el rango (Datos) indicado." & vbCr & _
      "Si el rango es una fila de varias columnas, indica verdadero para ""xColumnas""." & vbCr & _
      "El argumento ""Separa"" es opcional y (creo que) suficientemente ""logico""."
    .MacroOptions Macro:="ConcatenarSI", Category:=7, Description:= _
      "Devuelve la ""concatenacion"" de los datos en el rango (Datos) indicado." & vbCr & _
      "Siempre y cuando el primer rango (Criterios) coincida con la ""Condicion""." & vbCr & _
      "Los demas argumentos son opcionales y (creo que) suficientemente ""logicos""."
  End With: End Sub
Function AF_Activo(ByVal Ref As Range) As Boolean
  If Not Ref.Parent.AutoFilterMode Then Exit Function
  Dim Filtro As Byte: Application.Volatile
  With Ref.Parent.AutoFilter
    If Intersect(Ref.Cells(1, 1), .Range) Is Nothing Then Exit Function
    Filtro = Ref.Column - .Range.Column + 1: AF_Activo = .Filters(Filtro).On
  End With: End Function
Function Concatenado(Datos As Range, _
                        Optional xColumnas As Boolean = False, _
                        Optional Separa As String = " ") As String
  With Application: Concatenado = Join(IIf(xColumnas, _
    .Transpose(.Transpose(Datos)), .Transpose(Datos)), Separa): End With: End Function
Function ConcatenarSI(Criterios As Range, Condicion As String, Datos As Range, _
                        Optional Exacto As Boolean = False, _
                        Optional OmitirBlancos As Boolean = False, _
                        Optional Separa As String = " ") As String
  Dim Criterio As Range, Sig As Integer, Coincide As Boolean: ConcatenarSI = ""
  For Each Criterio In Criterios: Sig = Sig + 1
    Coincide = IIf(Exacto, Criterio = Condicion, LCase(Criterio) = LCase(Condicion))
    If OmitirBlancos Then Coincide = Coincide And Not IsEmpty(Datos.Cells(Sig))
    If Coincide Then ConcatenarSI = ConcatenarSI & IIf(Len(ConcatenarSI), Separa, "") & Datos.Cells(Sig)
  Next: End Function

 

Option Private Module
#If Not VBA6 Then
Function Replace(ByVal Texto As String, Busca As String, Reemplaza As String) As Variant
  Replace = Application.Substitute(Texto, Busca, Reemplaza): End Function
Function Split(Cadena As String, Delimitador As String) As Variant
  Split = Evaluate("{""" & Application.Substitute(Cadena, Delimitador, """,""") & """}"): End Function
Function Join(Matriz, Optional Separa As String) As String
  Dim Texto As String, Sig As Integer: On Error GoTo Join_error
  If VarType(Matriz) >= vbArray Then
    Texto = Matriz(LBound(Matriz))
    If UBound(Matriz) Then
      For Sig = LBound(Matriz) + 1 To UBound(Matriz)
        Texto = Texto & IIf(Len(Separa), Separa, "") & Matriz(Sig)
      Next: End If: Join = Texto
  Else: Join = CStr(Matriz)
  End If: Exit Function
Join_error:
  If Err.Number <> 0 Then Join = Err.Description
End Function
#End If

 

Option Private Module
Private Const keyLocal As String = "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Local "

Sub AveriguaMiEntorno()
 Dim vista As Boolean, ClaveWin As String: With CreateObject("wscript.shell")
  vista = .RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\CurrentVersion")
  ClaveWin = IIf(Val(vista) < 6, "AppData", "Settings"): MsgBox _
       "Perfil en:" & vbCr & vbTab & Environ("UserProfile") & vbCr & _
      "Escritorio en:" & vbCr & vbTab & .SpecialFolders("Desktop") & vbCr & _
      "Mis documentos en:" & vbCr & vbTab & .SpecialFolders("MyDocuments") & vbCr & _
      "Configuracion local en:" & vbCr & vbTab & .RegRead(keyLocal & ClaveWin) & vbCr & _
      "Datos de programa en:" & vbCr & vbTab & .SpecialFolders("AppData") & vbCr & vbTab & .RegRead(keyLocal & "AppData") & vbCr & _
      "Temporales en:" & vbCr & vbTab & .RegRead(keyLocal & ClaveWin) & "\Temp", , "Entorno de trabajo del usuario actual ..."
  End With: End Sub
Sub Capitaliza(Opcion As Byte): On Error Resume Next
  If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
  Dim ModoCalc, Eventos As Boolean, VolverA As Object, Confirma As Integer, Cambio, _
         AplicarEn As Range, Frase As Boolean, Celda As Range
  With Application: .ScreenUpdating = False: Eventos = .EnableEvents
    ModoCalc = .Calculation: .Calculation = xlCalculationManual
    If TypeName(Selection) <> "Range" Then Set VolverA = Selection: ActiveCell.Activate
    If Selection.Count = 1 Then
      Confirma = MsgBox("La seleccion actual es de ""solamente"" una celda..." & vbCr & _
                        "Deseas aplicar el cambio en todas las celdas de la hoja ?", _
                        vbYesNoCancel + vbDefaultButton2, "Confirmacion requerida !!!")
      If Confirma = vbCancel Then GoTo EndSub
      Set AplicarEn = IIf(Confirma = vbNo, ActiveCell, _
        ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, xlTextValues))
    Else: Set AplicarEn = Selection.SpecialCells(xlCellTypeConstants, xlTextValues)
    End If: Select Case Opcion: Case 0: GoTo SelectCase
      Case 1: Cambio = vbUpperCase: Case 2: Cambio = vbLowerCase
      Case 3: Cambio = vbProperCase: Case 4: Frase = True: End Select: GoTo Execute
SelectCase:
    Select Case UCase(Left(Trim(InputBox("Elige el tipo de ""salida""" & vbCr & _
        "[T] = Titulo" & vbTab & "[ I ] = minusculas" & vbCr & _
        "[F] = Frase" & vbTab & "[A] = MAYUSCULAS", "Alternar (May/min)usculas...")), 1))
      Case "A": Cambio = vbUpperCase: Case "I": Cambio = vbLowerCase
      Case "T": Cambio = vbProperCase: Case "F": Frase = True: Case Else: GoTo EndSub
    End Select
Execute:
    For Each Celda In AplicarEn: If Frase _
        Then Celda = UCase(Left(Celda, 1)) & LCase(Mid(Celda, 2)) _
        Else Celda = StrConv(Celda, Cambio)
    Next
EndSub:
    .Calculation = ModoCalc: .EnableEvents = Eventos: End With: Set AplicarEn = Nothing
  If Not VolverA Is Nothing Then VolverA.Select: Set VolverA = Nothing
End Sub
Sub CapitalizaComoWord(): On Error Resume Next
  If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
  Dim ModoCalc, Eventos As Boolean, VolverA As Object, Confirma As Integer, Cambio, _
         AplicarEn As Range, Frase As Boolean, Celda As Range
  With Application: .ScreenUpdating = False: Eventos = .EnableEvents
    ModoCalc = .Calculation: .Calculation = xlCalculationManual
    If TypeName(Selection) <> "Range" Then Set VolverA = Selection: ActiveCell.Activate
    If Selection.Count = 1 Then
      Confirma = MsgBox("La seleccion actual es de ""solamente"" una celda..." & vbCr & _
                        "Deseas aplicar el cambio en todas las celdas de la hoja ?", _
                        vbYesNoCancel + vbDefaultButton2, "Confirmacion requerida !!!")
      If Confirma = vbCancel Then GoTo EndSub2
      Set AplicarEn = IIf(Confirma = vbNo, ActiveCell, _
        ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, xlTextValues))
    Else: Set AplicarEn = Selection.SpecialCells(xlCellTypeConstants, xlTextValues)
    End If
    If ActiveCell = StrConv(ActiveCell, vbProperCase) Then GoTo SkipCase2 Else Cambio = vbUpperCase
    If ActiveCell = UCase(ActiveCell) Then Cambio = vbLowerCase
    If ActiveCell = LCase(ActiveCell) Then Cambio = vbProperCase
    For Each Celda In AplicarEn: Celda = StrConv(Celda, Cambio): Next: GoTo EndSub2
SkipCase2:
    For Each Celda In AplicarEn: Celda = UCase(Left(Celda, 1)) & LCase(Mid(Celda, 2)): Next
EndSub2:
    .Calculation = ModoCalc: .EnableEvents = Eventos: End With: Set AplicarEn = Nothing
  If Not VolverA Is Nothing Then VolverA.Select: Set VolverA = Nothing
End Sub
Sub ListaHojas(): On Error GoTo DoNothing
  Debug.Print ActiveSheet.Type
  With Application.CommandBars("workbook tabs").Controls(16)
    If Right(.Caption, 3) = "..." Then .Execute Else .Parent.ShowPopup
  End With
DoNothing:
End Sub
Sub OrdenaHojas(): On Error GoTo DoNothing2 ' NO importa si son [may/min]usculas '
  Debug.Print ActiveSheet.Type
  Dim x As String, n As Integer, a As Integer, b As Integer
  Select Case MsgBox("Ordenar en descendente ?", vbYesNoCancel, "Ordenar las hojas...")
    Case vbNo: x = "<": Case vbYes: x = ">": Case vbCancel: Exit Sub
  End Select: Application.ScreenUpdating = False
  With ActiveSheet: With ActiveWorkbook.Worksheets
      For n = 1 To .Count: b = n: For a = n + 1 To .Count
          If Evaluate("""" & .Item(a).Name & """" & x & """" & .Item(b).Name & """") Then b = a
        Next: If b <> n Then .Item(b).Move .Item(n)
      Next: End With: .Select: End With
DoNothing2:
End Sub
Sub OrdenaHojasM(): On Error GoTo DoNothing3 ' SI se distingue entre [may/min]usculas '
  Debug.Print ActiveSheet.Type
  Dim Sig As Integer, Ant As Integer, Post As Integer, Desc As Boolean
  Select Case MsgBox("Ordenar en descendente ?", vbYesNoCancel, "Ordenar las hojas...")
    Case vbNo: Desc = True: Case vbYes: Desc = False: Case vbCancel: Exit Sub
  End Select: Application.ScreenUpdating = False
  With ActiveSheet: With ActiveWorkbook.Worksheets
      For Sig = 1 To .Count: Post = Sig: For Ant = Sig + 1 To .Count
          If Desc Then
            If .Item(Ant).Name > .Item(Post).Name Then Post = Ant
          Else
            If .Item(Ant).Name < .Item(Post).Name Then Post = Ant
          End If: Next: If Post <> Sig Then .Item(Post).Move .Item(Sig)
      Next: End With: .Select: End With
DoNothing3:
End Sub
Sub Terminar(): Application.OnKey "%{f3}"
  If BarraInstalada Then Elimina_miBarra
  If Cinta Then TerminaSesion
  With Workbooks(misMacros & ".xls"): .Saved = True: Cerrando = True: .Close: End With: End Sub
Sub TocTocDesdeLaCinta(QuienLlama As Variant) ' Esta macro solo opera desde los botones en la Cinta de opciones (Ribbon) '
  Dim Fulanito As IRibbonControl: Set Fulanito = QuienLlama
  With Application: Select Case Fulanito.Id: Case "dCase": .Run "Capitaliza", 0
      Case "bMay": .Run "Capitaliza", 1: Case "bMin": .Run "Capitaliza", 2
      Case "bProp": .Run "Capitaliza", 3: Case "bFra": .Run "Capitaliza", 4
      Case "bWord": .Run "CapitalizaComoWord": Case "bPick": .Run "ListaHojas"
      Case "bSort": .Run "OrdenaHojas": Case "bSort2": .Run "OrdenaHojasM"
      Case "bEnv": .Run "AveriguaMiEntorno": Case "bExit": .Run "Terminar": End Select: End With: Set Fulanito = Nothing: End Sub

 

Anotaciones a tener en cuenta

 

Cuando el archivo: (mis Macros Favoritas.xls) se abre en la versión 2007, pueden ocurrir varias situaciones:

 

  1. Si se ha modificado su nombre, te avisa que el Ribbon NOse podrá utilizar
  2. Si NO encuentra "al segundo" (mis Macros en la Cinta.xlam) presenta un mensaje similar al anterior
  3. en ambos casos te da la opciónpor si quieres agregar botones(estilo 97/2003) en la ficha \"Complementos\"Office 2007. 
  4. TocTocDesdeLaCinta: este procedimiento SOLO se utiliza por y para la versión 2007 si se abre \" el segundo\" (*.xlam)  

Descarga del archivo

Favoritas.zip (31.9 kB)

 

Referencias

Bases en referencia
 
John Green (et.al): http://www.oaltd.co.uk/