MACROS (II)

Ejemplos de macros

En esta página iremos insertando macros  y códigos que pueden servirle de ayuda.

Macro para solicitar confirmación de salir de Excel. Macro que solicita al usuario que confirme salir de Excel
Private Sub salir()
If msgbox(“¿Desea salir de Excel?”,vbQuestion+ vbYesNo)=vbYes Then
Application.quit
End If
End Sub

Macro para guardar archivo seleccionando ubicación
Sub guardar_archivo()
Dim stArchivo
stArchivo = Application.GetOpenFilename(“Hoja de Excel , *.xls*”, _
, “Seleccione archivo “)
End Sub

Macro para guardar archivos en otro formato
Sub guardar_archivo_otro()
‘con esta macro guardamos el archivo con la fecha y hora actual y formato csv
Dim nombre, nombrearch, hoja, ruta
nombre = Format(Now, “dd-mm-yy hh.mm.ss”)
ruta = ActiveWorkbook.Path
nombrearch = ActiveWorkbook.Name
hoja = ActiveSheet.Name
ActiveWorkbook.SaveAs Filename:=ruta & “” & hoja & nombre & “.csv”, FileFormat:=xlCSV
ActiveSheet.SaveAs ruta & “” & nombrearch & nombre & “.xlsm”
End Sub

Copiar rango de una hoja a otra
Si queremos que se quiera copiar los rangos de la hoja activa de una hoja a otra ejecutariamos la macro siguiente:
Option Explicit
Dim f, c
Public Sub CopiarRango()
ActiveCell.CurrentRegion.Select
f = ActiveCell.Row
c = ActiveCell.Column
Selection.Copy
Sheets(“Hoja2″).Activate
Cells(f, c).Activate
ActiveSheet.Paste
End Sub

Cerrar libro Excel (guardar cambios)

ActiveWorkbook.Close
ActiveWorkbook.Close Savechanges:=True
ActiveWorkbook.Close(True)

Cerrar libro Excel (sin guardar cambios)

ActiveWorkbook.Close(False)
ActiveWorkbook.Close Savechanges:=False

Cerrar libro Excel (variable, sin guardar cambios)

Application.DisplayAlerts = False Windows(Libro_mayor).Close Application.DisplayAlerts = True

Abrir libro Excel (ruta fija) 
Workbooks.Open FileName:=”C:TrabajoInforme.xls”
Desplazarnos a la última hoja del libro
Sub ultima_hoja()
Sheets(Sheets.Count).Select
End Sub
Desplazarnos a la primera hoja del libro
Sub primera_hoja()
Sheets(1).Select
End Sub

Copiar el contenido seleccionado en otra hoja
Sub CopiaColumnas()
Dim mirango As Range
Dim col As Range
Dim NuevaHoja As Worksheet
Dim i As Integer
Set mirango = Selection
Worksheets.Add
i = 0
For Each col In mirango.Columns
col.Copy ActiveSheet.Range(“A1″).Offset(, i)
i = i + 1
Next col
End Sub

Macro para crear índices de hojas en libros
<Private Sub Worksheet_Activate()
Dim cHoja As Worksheet
Dim L As Long
L = 1
With Me
.Columns(1).ClearContents
.Cells(1, 1) = “INDICE”
.Cells(1, 1).Name = “Indice”
End With
For Each cHoja In Worksheets
If cHoja.Name <> Me.Name Then
L = L + 1
With cHoja
.Range(“A1″).Name = “Inicio” & cHoja.Index
.Hyperlinks.Add Anchor:=.Range(“A1″), Address:=” “, SubAddress:=”Indice”, TextToDisplay:=”Volver al índice”
End With
Me.Hyperlinks.Add Anchor:=Me.Cells(L, 1), Address:=” “, SubAddress:=”Inicio” & cHoja.Index, TextToDisplay:=cHoja.Name
End If
Next cHoja
End Sub

Macro para imprimir hoja activa con datos
Sub macro imprimir_ha()
Range(“A1″) = “Lo que sea”
‘Imprimimos la hoja de excel con una sola copia
ActiveWindow.SelectedSheets.PrintOut Copies:=1
End Sub

Buscar la última fila vacía
Sub ultimafila()
‘variable donde almacenamos el número de fila
Dim ultima As Long

‘vamos subiendo por la columna A desde la última fila
ultima = Range(“A65536″).End(xlUp).Row

‘le sumamos una porque queremos la 1ª fila vacía
ultima = ultima + 1
‘seleccionamos si queremos otra columna cambiar el número
Cells(ultima, 1).Select
End Sub

Encontrar última fila (en columna especificada)
Dim intUltimaFila As Range

If WorksheetFunction.CountA(Columns(1)) > 0 Then
Set intUltimaFila = Range(“65536″).End(xlUp)
MsgBox intUltimaFila.Address
End If

Suprimir filas vacías

intLastRow = Columns(“A:A”).Range(“A65536″).End(xlUp).Row
For r = intLastRow To 1 Step -1
If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete
Next r

Suprimir filas vacías

Dim intNumDeFilas As Long

Selection.SpecialCells(xlCellTypeLastCell).Select
intNumDeFilas = Selection.Row
For i = 1 To intNumDeFilas
If Application.WorksheetFunction.CountA(Rows(i)) = 0 Then
Rows(i).Delete
End If
Next

intUltimaFila = ActiveSheet.UsedRange.Row – 1 + ActiveSheet.UsedRange.Rows.Count

For r = intUltimaFila To 1 Step -1
If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete
Next r

Suprimir filas por condición

Dim rngString As Range

Do
Set rngString = Cells.Find(“Aglis”, MatchCase:=False, _
LookAt:=xlPart, LookIn:=xlValues)
If Not rngString Is Nothing Then
rngString.EntireRow.Delete
End If
Loop Until rngString Is Nothing

Suprimir filas vacías por dos condiciónes X, Y

For i = intUltimaFila To 1 Step -1
Let strTest= Application.Cells(i, 2)
If strTest <> “X” And strTest <> “Y” Then Rows(i).Delete
Next i

Macro que elimina las barras de desplazamiento

Sub elimina_barra()

    With ActiveWindow
.DisplayHorizontalScrollBar = False
.DisplayVerticalScrollBar = False
End With
End Sub

Macro que protege el libro y la hoja

Sub proteger()

ActiveWorkbook.Protect Password:=”1234″
Sheets(“Hoja1″).Protect Password:=”1234″
End Sub

Calculo del NIF

Esta función calcula el NIF (Número de Identificación Fiscal).

Function nif(dni As Long) As String
nif = Mid(“TRWAGMYFPDXBNJZSQVHLCKE”, (dni Mod 23) + 1, 1)
End Function