PROCEDIMIENTOS Y FUNCIONES VBA
En esta página iré poniendo procedimientos, funciones y código, escritos en VBA, que considere puedan ser útiles en general o que hagan cosas curiosas.
- Procedimiento que vuelca a una hoja de cálculo los ficheros contenidos en un directorio.
- Procedimiento para efectuar una búsqueda de ficheros y presentar los resultados en una hoja.
- Procedimiento para listar en una hoja todos los ficheros de un directorio y sus subdirectorios
- Procedimiento para enviar un rango por correo electrónico
- Procedimientos para enviar una hoja por correo electrónico
- Procedimiento para guardar un rango de una hoja de cálculo como archivo de imagen
- Procedimiento para eliminar filas duplicadas
- Función para crear un directorio que a su vez "cuelga" de otro u otros que no existen
- Procedimiento para ordenar las hojas de un libro por su nombre
- Procedimiento para justificar el texto en un grupo de celdas combinadas
- Procedimiento para distribuir aleatoriamente y sin repeticiones una serie de números en un rango
- Mostrar en un cuadro combinado el contenido de un rango sin valores repetidos
- Limpiar el histórico de elementos que aparecen en el desplegable de las tablas dinámicas
- Implementación en VBA del Tamiz de Eratóstenes para listar números primos
- Función para saber si un número es primo
- Descomposición factorial de un número
- Obtener la suma y/o la cuenta y/o la lista de los divisores de un número
Procedimiento DIR_EnHojaDeCálculo
Este procedimiento presenta en una hoja de cálculo los nombres de los ficheros contenidos en un directorio, junto con otros datos: tamaño, fecha de modificación y nombre corto:
Sub DIR_EnHojaDeCálculo() Dim fso As New FileSystemObject Dim fsFolder As Folder Dim fsFile As File Dim wksH As Worksheet Dim lngContLínea As Long lngContLínea = 2 Set fsFolder = fso.GetFolder("C:\") 'Directorio que se mostrará. Set wksH = Worksheets("Hoja1") 'Hoja en que se volcarán los datos On Error GoTo ManejoErrores With wksH 'Poner algunos títulos en la hoja de cálculo .Range("A1") = "Nombre" .Range("B1") = "Tamaño" .Range("C1") = "Fecha Modif." .Range("D1") = "Nombre largo" For Each fsFile In fsFolder.Files .Cells(lngContLínea, 1) = fsFile.ShortName .Cells(lngContLínea, 2) = fsFile.Size .Cells(lngContLínea, 3) = fsFile.DateLastModified .Cells(lngContLínea, 4) = fsFile.Name lngContLínea = lngContLínea + 1 Next fsFile .Cells(lngContLínea, 2).FormulaLocal = "=SUMA(B2:B" & Trim(Str(lngContLínea) - 1) & ")" .Range("B2:B" & Trim(Str(lngContLínea))).NumberFormat = "#,##0" .Columns("A:D").AutoFit End With Set wksH = Nothing Set fsFile = Nothing Set fsFolder = Nothing Set fso = Nothing Exit Sub ManejoErrores: 'En Windows XP, algunos ficheros del sistema (como el de paginación) carecen de nombre corto, por lo que hay que capturar el error que se produce al intentar acceder a él (propiedad ShortName). If Err.Number = 5 Then Resume Next Else MsgBox prompt:="Error " & Err.Number & " " & Err.Description, Buttons:=vbOKOnly + vbCritical Exit Sub End If End Sub
Para que este código funcione es necesario establecer una referencia a la libreria “Microsoft Scripting Runtime”, lo que se hace en Herramientas->Referencias, estando en el editor de VBA.
Procedimiento VerBúsquedaDeArchivosEnHoja
El siguiente procedimiento utiliza la propiedad FileSearch del objeto Application para efectuar una búsqueda de los ficheros con extensión .XLS, y presenta los ficheros (si los hay) en Hoja1:
Sub VerBúsquedaDeArchivosEnHoja() Dim fsB As FileSearch Dim n As Long Set fsB = Application.FileSearch With fsB .NewSearch .LookIn = "C:\Datos\Excel" 'Directorio donde comenzará la búsqueda .SearchSubFolders = False 'Si se buscará en los subdirectorios .Filename = "*.xls" 'Patrón a buscar If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) > 0 Then ActiveSheet.Range("A1") = "Nombre"
For n = 1 To fsB.FoundFiles.Count WorkSheets("Hoja1").Cells(n + 1, 1) = .FoundFiles(n) Next n
End If
End With
Set fsB = Nothing End Sub
Si la búsqueda se hace también en los subdirectorios (.SearchSubFolders = True) los ficheros pueden no presentarse correctamente ordenados por su nombre.
Procedimiento para listar en una hoja todos los ficheros de un directorio y sus subdirectorios
Notas:
- Las dos primeras instrucciones tienen que ir en la sección de declaraciones del módulo, así que lo más sencillo es poner el siguiente código en un módulo vacío.
- Hay que tener cuidado con el directorio a partir del cual se iniciará el listado (en el código, la instrucción EscribirArchivos ("C:\Datos"). Si se selecciona un directorio del que “cuelgan” muchos directorios y/o ficheros (por ejemplo, C:\), el proceso puede ser largo, e incluso podrían excederse las 65.536 filas de la hoja.
Public wksH As Worksheet
Public lngContFila As Long
Sub Llamar()
Set wksH = Worksheets("Hoja1") 'Hoja donde se mostrarán los ficheros
Dim fso As Object, fCarpeta As Object, tmpCarpeta As Object
Dim Fichero As Object, tmpFichero As Object
Dim strRutaInicial As String
strRutaInicial = "C:\Datos\Excel" 'Ruta que se procesará
Set fso = CreateObject("Scripting.FileSystemObject")
Set fCarpeta = fso.GetFolder(strRutaInicial)
wksH.Range("A1") = "Ruta"
wksH.Range("B1") = "Nombre"
wksH.Range("C1") = "Tamaño"
wksH.Range("D1") = "Fecha Modif."
wksH.Range("E1") = "Nombre largo"
lngContFila = 2
For Each tmpFichero In fCarpeta.Files
wksH.Cells(lngContFila, 1) = fCarpeta.path
wksH.Cells(lngContFila, 2) = tmpFichero.ShortName
wksH.Cells(lngContFila, 3) = tmpFichero.Size
wksH.Cells(lngContFila, 4) = tmpFichero.DateLastModified
wksH.Cells(lngContFila, 5) = tmpFichero.Name
lngContFila = lngContFila + 1
If lngContFila > 65535 Then
MsgBox prompt:="Demasiados ficheros.", Buttons:=vbCritical + vbOKOnly, Title:="EscribirEnArchivos"
Exit Sub
End If
Next tmpFichero
Set tmpFichero = Nothing
Set Fichero = Nothing
Set tmpCarpeta = Nothing
Set fCarpeta = Nothing
Set fso = Nothing
EscribirArchivos2 strRutaInicial
With wksH
.Range("A1:E1").HorizontalAlignment = xlCenter
.Range("A1:E1").Font.Bold = True
.Cells(lngContFila, 3).Formula = "=SUM(C2:B" & lngContFila - 1 & ")"
.Range("C2:C" & lngContFila).NumberFormat = "#,##0"
.Range("D2:D" & lngContFila).NumberFormat = "dd-mm-yy hh:mm:ss"
End With
wksH.Columns("A:E").AutoFit
Set wksH = Nothing
End Sub
Public Sub EscribirArchivos2(RutaInicial As String)
On Error GoTo ManejoErrores
Dim fso As Object, fCarpeta As Object, tmpCarpeta As Object
Dim Fichero As Object, tmpFichero As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set fCarpeta = fso.GetFolder(RutaInicial)
For Each tmpCarpeta In fCarpeta.SubFolders
For Each tmpFichero In tmpCarpeta.Files
wksH.Cells(lngContFila, 1) = tmpCarpeta.path
wksH.Cells(lngContFila, 2) = tmpFichero.ShortName
wksH.Cells(lngContFila, 3) = tmpFichero.Size
wksH.Cells(lngContFila, 4) = tmpFichero.DateLastModified
wksH.Cells(lngContFila, 5) = tmpFichero.Name
lngContFila = lngContFila + 1
If lngContFila > 65535 Then
MsgBox prompt:="Demasiados ficheros.", Buttons:=vbCritical + vbOKOnly, Title:="EscribirEnArchivos"
Exit Sub
End If
Next
EscribirArchivos2 tmpCarpeta.path
Next
Set tmpFichero = Nothing
Set Fichero = Nothing
Set tmpCarpeta = Nothing
Set fCarpeta = Nothing
Set fso = Nothing
Exit Sub
ManejoErrores:
'En Windows XP, algunos ficheros del sistema (como el de paginación) carecen de nombre corto, por lo que hay que capturar el error que se produce al intentar acceder a él (propiedad ShortName).
If Err.Number = 5 Then Resume Next Else MsgBox Err.Number & Err.Description
End Sub
Temas relacionados:
Libro de ejemplo con el código anterior funcionando, con la posibilidad de seleccionar el directorio a partir del cual comenzará el listado.
Lo anterior, pudiendo elegir también una extensión de fichero a listar
Procedimiento para enviar un rango por correo electrónico
El siguiente procedimiento crea un libro nuevo con una sola hoja, pega en su Hoja1 el rango A1:E20 de la hoja activa en el momento de ejecutarlo, y envía el libro por correo electrónico a la dirección que se le indique:
Sub EnviarRango() Dim wbL As Workbook Set wbL = Workbooks.Add(xlWBATWorksheet) ThisWorkbook.Worksheets("Hoja1").Range("A1:E20").Copy Destination:=wbL.Worksheets(1).Range("A1") wbL.SendMail Recipients:="dirección@dominio", Subject:="Envío de libro Excel" wbL.Close savechanges:=False Set wbL = Nothing End Sub
Procedimientos para enviar una hoja por correo electrónico
Es posible enviar una sola hoja de un libro por correo electrónico, pero hay que situarla en un libro.
Si no importa el nombre del libro que se enviará, es posible evitar tener que guardar el libro y borrarlo después del envío usando el siguiente código:
Sub EnviarHojaPorCorreoElectrónico() ActiveSheet.Copy ActiveWorkbook.SendMail Recipients:="dirección@dominio", Subject:="Envío libro de Excel" ActiveWorkbook.Close savechanges:=False End Sub
Pero si es necesario que el libro tenga un nombre determinado, habría que guardar el libro para asignarle dicho nombre, y luego eliminarlo:
Sub EnviarHojaPorCorreoElectrónico() Dim strNombre As String ActiveSheet.Copy With ActiveWorkbook .SaveAs "C:\NombreDelLibro.xls" .SendMail Recipients:="dirección@dominio", Subject:="Envío libro de Excel" strNombre = .FullName .Close End With Kill strNombre End Sub
Procedimiento para guardar un rango de una hoja de cálculo como archivo de imagen
El siguiente código guarda un rango de una hoja de cálculo como imagen. El formato de dicha imagen puede ser cualquiera de los almacenados en esta clave del registro de windows:
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Shared Tools\Graphics Filters\ExportNormalmente, dichos tipos suelen ser GIF, JPG y BMP
Sub GuardarImagen() Dim choObj As ChartObject, chGráf As Chart, ptImagen As Object Dim blnGuardado As Boolean Worksheets("Hoja1").Range("A1:I26").CopyPicture appearance:=xlScreen, Format:=xlPicture Set choObj = ActiveSheet.ChartObjects.Add(0, 0, 800, 600) Set chGráf = choObj.Chart choObj.Activate chGráf.ChartArea.Select chGráf.Paste Set ptImagen = chGráf.Pictures(1) ptImagen.Left = 0 ptImagen.Top = 0 choObj.Border.LineStyle = xlNone choObj.Width = ptImagen.Width + 7 choObj.Height = ptImagen.Height + 7 blnGuardado = chGráf.Export(Filename:="C:\ImagenExcel.GIF", filtername:="GIF") If Not blnGuardado Then MsgBox prompt:="Problemas al guardar la imagen.", Buttons:=vbOKOnly + vbExclamation choObj.Delete Set choObj = Nothing Set chGráf = Nothing Set ptImagen = Nothing End Sub
En este ejemplo se guarda el rango A1:I26 de Hoja1 como GIF.
Si el rango a guardar fuera muy grande, habría que cambiar el parámetro con nombre Appearance (que en el código está como xlScreen) a xlPrinter. La instrucción quedaría, pues:
Worksheets("Hoja1").Range("A1:I26").CopyPicture
appearance:=xlPrinter, Format:=xlPicture
Procedimiento para eliminar filas duplicadas
El siguiente código elimina las filas cuya columna A esté duplicada. El número de columna a procesar se determina en la línea que empieza con "intNúmcol = ", y la columna se procesará mientras no se encuentre una fila vacía en dicha columna.
Es recomendable probar este código con una copia del libro mejor que con los datos reales, por si no hiciera exactamente lo que se necesita.
Sub BorrarDuplicados() Dim wksH As Worksheet Dim lngContFila As Long, lngCalculo As Long, intNúmCol As Integer Set wksH = Worksheets("Hoja1") 'Hoja que se procesará lngCalculo = Application.Calculation Application.Calculation = xlCalculationManual Application.ScreenUpdating = False lngContFila = 1 'Si hay títulos tendrá que ser el número de la última fila de títulos +1 intNúmCol = 2 'El número de columna por la que se desea eliminar los duplicados (A=1, B=2, etc.) While Not IsEmpty(wksH.Cells(lngContFila, intNúmCol)) If WorksheetFunction.CountIf(wksH.Columns(intNúmCol), wksH.Cells(lngContFila, intNúmCol)) > 1 Then wksH.Cells(lngContFila, intNúmCol).EntireRow.Delete Else lngContFila = lngContFila + 1 End If Wend Application.ScreenUpdating = True Application.Calculation = lngCalculo Set wksH = Nothing End Sub
Función para crear un directorio que a su vez "cuelga" de otro u otros que no existe/n.
Mediante VBA es posible crear un directorio usando la instrucción MkDir, pero el directorio a crear debe "colgar" de uno ya existente. Si, por ejemplo, se necesita crear el directorio C:\a\b\c y no existe el directorio a, MkDir falla. La siguiente función crea la ruta completa:
Function CrearDirectorio(strRuta As String) As Boolean 'Sintaxis: CrearDirectorio("Unidad:\Directorio1\Directorio2\...\Directorio n") Dim fsoF As Object Set fsoF = CreateObject("Scripting.FileSystemObject") Dim mtr() As String, n As Integer, strCreandoRuta As String mtr = Split(strRuta, "\") If UBound(mtr) - LBound(mtr) = 0 Then Exit Function 'La ruta que se quiere crear no es correcta If Dir(mtr(LBound(mtr))) = "" Then Exit Function 'La unidad no existe strCreandoRuta = mtr(LBound(mtr())) For n = LBound(mtr) + 1 To UBound(mtr) strCreandoRuta = strCreandoRuta & Application.PathSeparator & mtr(n) If Not fsoF.FolderExists(strCreandoRuta) Then fsoF.CreateFolder strCreandoRuta Next n Set fsoF = Nothing CrearDirectorio = True 'La función devuelve True para indicar que la ruta se pudo crear End Function
La sintaxis es la indicada en la propia función.
La función devolverá True si consiguió crear la ruta y False en caso contrario.
Procedimiento para ordenar las hojas de un libro por su nombre
El código usa el método de ordenación llamado "de burbuja", el cual es lento comparado con otros que requieren más líneas de código, pero suficiente para ordenar un número razonable de hojas.
Sub OrdenarHojas() Dim wksH As Worksheet Dim mtrHojas() As String Dim intBucle As Integer Dim blnOrdenado As Boolean Dim strCambio As String ReDim mtrHojas(1 To ThisWorkbook.Worksheets.Count) For Each wksH In ThisWorkbook.Worksheets mtrHojas(wksH.Index) = wksH.Name Next Do blnOrdenado = True For intBucle = 1 To UBound(mtrHojas) - 1 If mtrHojas(intBucle) > mtrHojas(intBucle + 1) Then strCambio = mtrHojas(intBucle) mtrHojas(intBucle) = mtrHojas(intBucle + 1) mtrHojas(intBucle + 1) = strCambio blnOrdenado = False Exit For End If Next intBucle If blnOrdenado Then Exit Do Loop Application.ScreenUpdating = False For intBucle = UBound(mtrHojas) To LBound(mtrHojas) Step -1 Sheets(mtrHojas(intBucle)).Move before:=Sheets(1) Next intBucle Application.ScreenUpdating = True Set wksH = Nothing End Sub
Si se necesitara ordenar las hojas en orden descendente, bastaría con cambiar el signo > de la instrucción
If mtrHojas(intBucle) > mtrHojas(intBucle + 1) Then
por <, con lo que quedaría:
If mtrHojas(intBucle) < mtrHojas(intBucle + 1) Then
Procedimiento para justificar el texto en un grupo de celdas combinadas
Excel es capaz de justificar el texto que haya en una celda no combinada, pero no lo hace en el caso de celdas combinadas.
El siguiente código se encarga de justificar el contenido del grupo de celdas combinadas B5:E5. Se trata tan sólo de un ejemplo ya que, lógicamente, habría que modificarlo en cada caso en función del rango a ajustar.
Sub
AjustarTextoEnCeldasCombinadas()
If Not ActiveSheet.Range("B5:E5").MergeCells Then Exit Sub
'Si el rango B5:E5 de la hoja activa no est combinado, salir sin hacer nada
Dim sngAnchoTotal As Single, sngAnchoCelda As Single, sngAlto
As Single
Dim n As Integer
For n = 2 To 5
sngAnchoTotal = sngAnchoTotal +
ActiveSheet.Cells(5, n).ColumnWidth
Next n
With ActiveSheet.Range("B5")
sngAnchoCelda = .ColumnWidth
.HorizontalAlignment = xlJustify
.VerticalAlignment = xlJustify
.MergeCells = False
.ColumnWidth = sngAnchoTotal
ActiveSheet.Rows(5).AutoFit
sngAlto = .RowHeight
End With
With ActiveSheet
.Range("B5:E5").Merge
.Columns(2).ColumnWidth =
sngAnchoCelda
.Rows(5).RowHeight = sngAlto
End With
End Sub
En este libro de ejemplo se ajustan automáticamente los rangos combinados de Hoja1 al editarlos.
Procedimiento para distribuir aleatoriamente y sin repeticiones una serie de números en un rango
El siguiente código distribuye aleatoriamente la serie 1 - 100 en el rango A1:A100 de Hoja1:
Sub
DistribuciónAleatoriaEnUnRango()
Dim col1 As New Collection, col2 As New Collection
Dim lngElem As Long
Dim n As Long
Application.ScreenUpdating = False
For n = 1 To 100
col1.Add n
Next n
For n = col1.Count To 1 Step -1
lngElem = Int(n * Rnd + 1)
col2.Add col1(lngElem)
col1.Remove lngElem
Next n
For n = 1 To col2.Count
Worksheets("Hoja1").Cells(n, 1) =
col2(n) 'Hoja y celdas donde se volcará el resultado (Hoja1!A1:A100)
Next n
Application.ScreenUpdating = True
End Sub
Partiendo del código anterior, sería
posible distribuir aleatoriamente otros tipos de datos. Por ejemplo, para
distribuir "a", "b", "c" y "d" en el rango A1:A4 lo único que habría que hacer
es sustituir el primer bucle For ... Next por:
col1.Add
"a"
col1.Add "b"
col1.Add "c"
col1.Add "d"
También sería posible distribuir aleatoriamente un rango en otro. Por ejemplo, para distribuir el rango C1:C20 de Hoja1 en A1:A20 de la misma hoja, habría que sustituir el primer bucle For ... Next por:
For n =
1 To 20
col1.Add
Worksheets("Hoja1").Range("C" & n).Value
Next n
Este código conviene usarlo si se desea fijar la distribución aleatoria en la hoja de cálculo. Si lo que se desea es que la distribución aleatoria cambie cada vez que se produzca un recálculo, es posible conseguirlo sin recurrir a VBA. En este libro de ejemplo se puede ver cómo.
Mostrar en un cuadro combinado el contenido de un rango sin valores repetidos
En un formulario tenemos un cuadro combinado
llamado ComboBox1, y queremos que al inicializar el formulario en dicho cuadro
aparezcan los valores de un rango con nombre llamado Lista.
El problema es que en dicho rango con nombre Lista existen valores que aparecen
varias veces pero, lógicamente, lo que nos interesa es que en el cuadro
combinado tan sólo aparezcan valores únicos.
El código para conseguirlo sería:
Private Sub UserForm_Initialize()
On Error GoTo captura
Dim n As Long
For n = 1 To
Range("Lista").Rows.Count
Me.ComboBox1.AddItem
Evaluate("=INDEX(Lista,SMALL(IF(MATCH(Lista,Lista,0)=ROW(INDIRECT(" & """1:""" &
"&COUNTA(Lista))),MATCH(Lista,Lista,0)," & """""" & ")," & n &
"-ROW(Lista)+1))")
Next n
Exit Sub
captura:
If Err.Number = -2147352571 Then Exit Sub Else MsgBox Err.Number & " - " &
Err.Description
End Sub
Este código tendría que situarse en el módulo del formulario.
Limpiar el histórico de elementos que aparecen en el desplegable de las tablas dinámicas
Los elementos que aparecen en la lista desplegable de las tablas dinámicas no se borran cuando ya no quedan dichos elementos en el rango de datos de que se nutre la tabla dinámica, sino que se quedan en una especie de "histórico" que, hasta donde yo sé, sólo es posible limpiar y actualizar usando código:
Sub Borrar_PivotItems()
'Este código actualiza los elementos que aparecen en el desplegable de la/s
tabla/s dinámica/s del libro.
Dim wksH As Worksheet
Dim ptP As PivotTable
Dim pfP As PivotField
Dim piP As PivotItem
Dim i As Integer
On Error Resume Next
For i = 1 To 2
For Each wksH In ActiveWorkbook.Worksheets
For Each ptP In wksH.PivotTables
For Each pfP In ptP.PivotFields
For Each piP In pfP.PivotItems
piP.Delete
Next
Next
ptP.RefreshTable
Next
Next
Next
Set piP = Nothing
Set pfP = Nothing
Set ptP = Nothing
Set wksH = Nothing
End Sub
El código anterior limpia y actualiza los desplegables de todas las tablas dinámicas del libro.
Implementación en VBA del Tamiz de Eratóstenes para listar números primos.
El siguiente código lista en la hoja Primos del libro donde se ejecute el código todos los números primos desde el 2 hasta el tope que se haya establecido en el propio código. Hay que tener en cuenta que, tal como está el código en esta página, necesita la existencia de dicha hoja llamada Primos y que la borrará por completo durante su ejecución.
Sub ListarNúmerosPrimos()
'Este código es una implementación en VBA del Tamiz de Eratóstenes para listar _
los números primos hasta el tope que se desee.
'Nota: para que este código funcione tal como está publicado en esta página web, _
es necesario que en el libro donde se ejecute haya una hoja que se llame _
Primos, teniendo en cuenta que el código borrará toda la hoja durante _
su ejecución
Dim a() As Boolean 'Matriz de trabajo
Dim lTope As Long
Dim lIterar1 As Long, lIterar2 As Long
Dim lFila As Long, btCol As Byte
lTope = 100000 'Asignar a la variable lTope el número máximo al que se _
quiere llegar en la búsqueda de números primos
ReDim a(1 To lTope)
lFila = 2
btCol = 1
'Proceso
For lIterar1 = 3 To Sqr(lTope) Step 2
If Not a(lIterar1) Then
For lIterar2 = lIterar1 ^ 2 To lTope Step lIterar1
a(lIterar2) = True
Next lIterar2
End If
Next lIterar1
'Listado
Application.ScreenUpdating = False
With Worksheets("Primos")
.Cells.Delete
.[A1] = 2
For lIterar1 = 3 To lTope Step 2
If Not a(lIterar1) Then
.Cells(lFila, btCol).Value = lIterar1
lFila = lFila + 1
If lFila = 65537 Then
lFila = 1
btCol = btCol + 1
End If
End If
Next lIterar1
End With
Application.ScreenUpdating = True
End Sub
Función para saber si un número es primo
Option Base 1
Public Function
EsPrimo(ByVal cNúmero As Currency) As Boolean
'Sintaxis: EsPrimo(celda o número)
'Nota: el entero más alto que puede procesar esta función es
el límite para _
el tipo de datos Currency (922.337.203.685.477)
If (Residuo(cNúmero, 2) = 0 And cNúmero <> 2) Or _
(Residuo(cNúmero, 3) = 0 And cNúmero <> 3)
Or _
(Residuo(cNúmero, 5) = 0 And cNúmero <> 5)
Then _
Exit Function
Dim cDivisor As Currency
cDivisor = 7
While cDivisor <= Sqr(cNúmero) + 1
If Residuo(cNúmero, cDivisor) = 0
Then Exit Function
cDivisor = cDivisor +
IIf(Right(CStr(cDivisor), 1) = 3, 4, 2)
Wend
EsPrimo = True
End Function
Private Function Residuo(ByVal cNumerador As Currency, ByVal cDenominador As Currency) As Currency
'Debido a que el límite con el que puede trabajar la función Mod de VBA es el del tipo de datos _
Long (2.147.483.647), es necesario calcular los residuos "a mano".
Residuo = cNumerador - cDenominador * Int(cNumerador / cDenominador)
End Function
Descomposición factorial de un número
La descomposición
factorial de un número (también llamada descomposición en factores primos) es su expresión como potencias de números primos. Por
ejemplo, la descomposición factorial del número 2010 es 2*3*5*67.
Lógicamente, la descomposición factorial de un número primo es el propio número
y 1.
Partiendo de la función anterior (EsPrimo) para saber si un número es primo, es posible
escribir otra para realizar la descomposición factorial de cualquier entero
positivo, con
el límite del tipo de datos Currency de VBA, esto es 922.337.203.685.477,
teniendo en cuenta que el procesamiento de números tan grandes puede llevar bastante
tiempo.
El código de la función es:
Public Function DescFact(ByVal cNúmero As Currency) As String
'Sintaxis: DescFact(celda o número)
'Nota: el entero más alto que puede procesar esta función es (en teoría) el límite para _
el tipo de datos Currency (922.337.203.685.477), pero los cálculos necesarios para _
números tan grandes pueden llevar bastante tiempo.
'Si el número pasado como argumento a la función es primo, terminar
If EsPrimo(cNúmero) Then
DescFact = "=" & CStr(cNúmero)
Exit Function
End If
'Variables
Dim mtrN() As Currency, mtrE() As Byte
Dim cTope As Currency, cProcesando As Currency, cDivisor As Currency
Dim n As Currency
'Inicializaciones
DescFact = "="
cProcesando = cNúmero
cTope = 1
cDivisor = 7
'Antes de empezar el bucle principal, se evalua si el número es divisible por 2, 3 y 5 & _
para luego poder entrar directamente en el ciclo 7 - 9 - 1 - 3 (los números terminados en 5 & _
siempre son divisibles por 5, por lo que no hay que procesarlos)
If Residuo(cProcesando, 2) = 0 Then
ReDim mtrN(cTope): ReDim mtrE(cTope)
mtrN(cTope) = 2
While Residuo(cProcesando, 2) = 0
mtrE(cTope) = mtrE(cTope) + 1
cProcesando = cProcesando / 2
Wend
cTope = cTope + 1
End If
If Residuo(cProcesando, 3) = 0 Then
ReDim Preserve mtrN(cTope): ReDim Preserve mtrE(cTope)
mtrN(cTope) = 3
While Residuo(cProcesando, 3) = 0
mtrE(cTope) = mtrE(cTope) + 1
cProcesando = cProcesando / 3
Wend
cTope = cTope + 1
End If
If Residuo(cProcesando, 5) = 0 Then
ReDim Preserve mtrN(cTope): ReDim Preserve mtrE(cTope)
mtrN(cTope) = 5
While Residuo(cProcesando, 5) = 0
mtrE(cTope) = mtrE(cTope) + 1
cProcesando = cProcesando / 5
Wend
cTope = cTope + 1
End If
'Si cProcesando = 1, terminar
If cProcesando = 1 Then GoTo Listar
'Si cProcesando es primo, terminar
If EsPrimo(cProcesando) Then
If cTope = 1 Then
ReDim mtrN(cTope): ReDim mtrE(cTope)
Else
ReDim Preserve mtrN(cTope): ReDim Preserve mtrE(cTope)
End If
mtrN(cTope) = cProcesando: mtrE(cTope) = 1
GoTo Listar
End If
'Bucle principal
While cProcesando > 1
If Residuo(cProcesando, cDivisor) = 0 Then
If EsPrimo(cDivisor) Then
While Residuo(cProcesando, cDivisor) = 0
ReDim Preserve mtrN(cTope): ReDim Preserve mtrE(cTope)
mtrN(cTope) = cDivisor: mtrE(cTope) = mtrE(cTope) + 1
cProcesando = cProcesando / cDivisor
Wend
cTope = cTope + 1
End If
If cProcesando = 1 Then GoTo Listar
If (cProcesando < Sqr(cNúmero)) And cProcesando > 1 Then
ReDim Preserve mtrN(cTope): ReDim Preserve mtrE(cTope)
mtrN(cTope) = cProcesando: mtrE(cTope) = 1
GoTo Listar
End If
'Si cProcesando es primo, terminar
If EsPrimo(cProcesando) Then
ReDim Preserve mtrN(cTope): ReDim Preserve mtrE(cTope)
mtrN(cTope) = cProcesando: mtrE(cTope) = 1
cProcesando = 1
End If
End If
cDivisor = cDivisor + IIf(Right(CStr(cDivisor), 1) = 3, 4, 2)
Wend
Listar:
For n = LBound(mtrN) To UBound(mtrN)
DescFact = DescFact & CStr(mtrN(n)) & IIf(mtrE(n) = 1, "", "^" & CStr(mtrE(n))) & "*"
Next n
DescFact = Left(DescFact, Len(DescFact) - 1)
End Function
En este
libro de ejemplo están ambas funciones trabajando.
Obtener la suma y/o la cuenta y/o la lista de los divisores de un número
Tomando como base la función anterior es posible escribir una que devuelva la suma de los divisores de un número n, para lo que se usa la función sigma(n), la cual necesita la lista de los divisores del número y sus exponentes, que es precisamente lo que calcula la función anterior DescFact.
La función para la suma de los divisores de un número entero, por lo tanto, sería:
Option Base 1
Public Function SumaDivisores(ByVal cNúmero As Currency, Optional blIncluirNúmero As Boolean = True) As Currency
'Sintaxis: SumaDivisores(celda o número; [Incluir el propio número en la suma])
' (si se deja en blanco [Incluir el propio número en la suma] o se pone VERDADERO, la función _
incluirá el número en su suma de divisores)
'Nota: el entero más alto que puede devolver esta función es el límite para el tipo de datos _
Currency (922.337.203.685.477). Si la suma de los divisores de cNúmero es mayor, se producirá un error.
'Si cNúmero = 1, terminar
If cNúmero = 1 Then
SumaDivisores = 0 + IIf(blIncluirNúmero, cNúmero, 0)
Exit Function
End If
'Si el número pasado como argumento a la función es primo, terminar
If EsPrimo(cNúmero) Then
SumaDivisores = 1 + IIf(blIncluirNúmero, cNúmero, 0)
Exit Function
End If
'Variables
Dim mtrN() As Currency, mtrE() As Byte
Dim cTope As Currency, cProcesando As Currency, cDivisor As Currency
Dim n As Currency
'Inicializaciones
SumaDivisores = 1
cProcesando = cNúmero
cTope = 1
cDivisor = 7
'Antes de empezar el bucle principal, se evalua si el número es divisible por 2, 3 y 5 & _
para luego poder entrar directamente en el ciclo 7 - 9 - 1 - 3 (los números terminados en 5 & _
siempre son divisibles por 5, por lo que no hay que procesarlos)
If Residuo(cProcesando, 2) = 0 Then
ReDim mtrN(cTope): ReDim mtrE(cTope)
mtrN(cTope) = 2
While Residuo(cProcesando, 2) = 0
mtrE(cTope) = mtrE(cTope) + 1
cProcesando = cProcesando / 2
Wend
cTope = cTope + 1
End If
If Residuo(cProcesando, 3) = 0 Then
ReDim Preserve mtrN(cTope): ReDim Preserve mtrE(cTope)
mtrN(cTope) = 3
While Residuo(cProcesando, 3) = 0
mtrE(cTope) = mtrE(cTope) + 1
cProcesando = cProcesando / 3
Wend
cTope = cTope + 1
End If
If Residuo(cProcesando, 5) = 0 Then
ReDim Preserve mtrN(cTope): ReDim Preserve mtrE(cTope)
mtrN(cTope) = 5
While Residuo(cProcesando, 5) = 0
mtrE(cTope) = mtrE(cTope) + 1
cProcesando = cProcesando / 5
Wend
cTope = cTope + 1
End If
'Si cProcesando = 1, terminar
If cProcesando = 1 Then GoTo Cálculo
'Si cProcesando es primo, terminar
If EsPrimo(cProcesando) Then
If cTope = 1 Then
ReDim mtrN(cTope): ReDim mtrE(cTope)
Else
ReDim Preserve mtrN(cTope): ReDim Preserve mtrE(cTope)
End If
mtrN(cTope) = cProcesando: mtrE(cTope) = 1
GoTo Cálculo
End If
'Bucle principal
While cProcesando > 1
If Residuo(cProcesando, cDivisor) = 0 Then
If EsPrimo(cDivisor) Then
While Residuo(cProcesando, cDivisor) = 0
ReDim Preserve mtrN(cTope): ReDim Preserve mtrE(cTope)
mtrN(cTope) = cDivisor: mtrE(cTope) = mtrE(cTope) + 1
cProcesando = cProcesando / cDivisor
Wend
cTope = cTope + 1
End If
If cProcesando = 1 Then GoTo Cálculo
If (cProcesando < Sqr(cNúmero)) And cProcesando > 1 Then
ReDim Preserve mtrN(cTope): ReDim Preserve mtrE(cTope)
mtrN(cTope) = cProcesando: mtrE(cTope) = 1
GoTo Cálculo
End If
'Si cProcesando es primo, terminar
If EsPrimo(cProcesando) Then
ReDim Preserve mtrN(cTope): ReDim Preserve mtrE(cTope)
mtrN(cTope) = cProcesando: mtrE(cTope) = 1
GoTo Cálculo
End If
End If
cDivisor = cDivisor + IIf(Right(CStr(cDivisor), 1) = 3, 4, 2)
Wend
Cálculo:
For n = LBound(mtrN) To UBound(mtrN)
SumaDivisores = SumaDivisores * (((mtrN(n) ^ (mtrE(n) + 1)) - 1) / (mtrN(n) - 1))
Next n
If Not blIncluirNúmero Then SumaDivisores = SumaDivisores - cNúmero
End Function
Tal como consta en el cuerpo de la propia función, si se deja vacío su segundo argumento o se pone VERDADERO en él, la función devolverá la suma de los divisores del número incluyéndolo, mientras que si se pone FALSO la función lo excluirá.
La función para obtener la lista de los divisores de un número utiliza el método de encontrar todos sus factores primos para a continuación desarrollar todas las potencias de cada uno de ellos. Este método es más complicado de implementar en VBA, pero tiene la ventaja de ser muchísimo más rápido (va siendo comparativamente más rápido según más grande va siendo el número) que el más común método de dividir el número entre todos los números desde 2 hasta el número/2. El código es:
Public Function ListaDivisores(ByVal cNúmero As Currency, Optional blnOrdenar As Boolean = False) As String
'Sintaxis: =ListaDivisores(celda o número; [Ordenada]) donde [Ordenada] es opcional: & _
si se deja vacío el argumento o se pone FALSO, la lista de divisores podrá & _
estar desordenada, mientras que si se pone VERDADERO la lista se ordenará & _
(lo que consumirá algo más de tiempo de proceso)
'Nota: el entero más alto que puede procesar esta función es el límite para el tipo de datos _
Currency (922.337.203.685.477).
If cNúmero = 1 Then
ListaDivisores = "1"
Exit Function
End If
'Si el número pasado como argumento a la función es primo, terminar
If EsPrimo(cNúmero) Then
ListaDivisores = "1" & Application.International(xlListSeparator) & CStr(cNúmero)
Exit Function
End If
'Variables
Dim mtrN() As Currency, mtrE() As Byte
Dim cTope As Currency, cProcesando As Currency, cDivisor As Currency
Dim iCantidadDivisores As Integer, curMtrDivisores() As Currency, iColumnasMtrDivisores As Integer
Dim N As Integer, iFila As Integer, iColumna As Integer, j As Integer, k As Integer
Dim curMtrTrabajo() As Currency, iFilaReal As Integer, iPrimo As Integer
'Inicializaciones
cProcesando = cNúmero
cTope = 1
cDivisor = 7
'Lo primero que hay que hacer es obtener la descomposición factorial de cNúmero
'------------------------------------------------------------------------------
'Antes de empezar el bucle principal, se evalua si el número es divisible por 2, 3 y 5 & _
para luego poder entrar directamente en el ciclo 7 - 9 - 1 - 3 (los números terminados en 5 & _
siempre son divisibles por 5, por lo que no hay que procesarlos)
If Residuo(cProcesando, 2) = 0 Then
ReDim mtrN(cTope): ReDim mtrE(cTope)
mtrN(cTope) = 2
While Residuo(cProcesando, 2) = 0
mtrE(cTope) = mtrE(cTope) + 1
cProcesando = cProcesando / 2
Wend
cTope = cTope + 1
End If
If Residuo(cProcesando, 3) = 0 Then
ReDim Preserve mtrN(cTope): ReDim Preserve mtrE(cTope)
mtrN(cTope) = 3
While Residuo(cProcesando, 3) = 0
mtrE(cTope) = mtrE(cTope) + 1
cProcesando = cProcesando / 3
Wend
cTope = cTope + 1
End If
If Residuo(cProcesando, 5) = 0 Then
ReDim Preserve mtrN(cTope): ReDim Preserve mtrE(cTope)
mtrN(cTope) = 5
While Residuo(cProcesando, 5) = 0
mtrE(cTope) = mtrE(cTope) + 1
cProcesando = cProcesando / 5
Wend
cTope = cTope + 1
End If
'Si cProcesando = 1, terminar
If cProcesando = 1 Then GoTo CrearListaDivisores
'Si cProcesando es primo, terminar
If EsPrimo(cProcesando) Then
If cTope = 1 Then
ReDim mtrN(cTope): ReDim mtrE(cTope)
Else
ReDim Preserve mtrN(cTope): ReDim Preserve mtrE(cTope)
End If
mtrN(cTope) = cProcesando: mtrE(cTope) = 1
GoTo CrearListaDivisores
End If
'Bucle principal
While cProcesando > 1
If Residuo(cProcesando, cDivisor) = 0 Then
If EsPrimo(cDivisor) Then
While Residuo(cProcesando, cDivisor) = 0
ReDim Preserve mtrN(cTope): ReDim Preserve mtrE(cTope)
mtrN(cTope) = cDivisor: mtrE(cTope) = mtrE(cTope) + 1
cProcesando = cProcesando / cDivisor
Wend
cTope = cTope + 1
End If
If cProcesando = 1 Then GoTo CrearListaDivisores
If (cProcesando < Sqr(cNúmero)) And cProcesando > 1 Then
ReDim Preserve mtrN(cTope): ReDim Preserve mtrE(cTope)
mtrN(cTope) = cProcesando: mtrE(cTope) = 1
GoTo CrearListaDivisores
End If
'Si cProcesando es primo, terminar
If EsPrimo(cProcesando) Then
ReDim Preserve mtrN(cTope): ReDim Preserve mtrE(cTope)
mtrN(cTope) = cProcesando: mtrE(cTope) = 1
GoTo CrearListaDivisores
End If
End If
cDivisor = cDivisor + IIf(Right(CStr(cDivisor), 1) = 3, 4, 2)
Wend
CrearListaDivisores:
'Al llegar aquí, tendremos dos matrices: & _
- mtrN(), que contiene los factores primos de cNúmero, y & _
- mtrE(), que contiene sus exponentes & _
Ahora hay que desarrollar las potencias de cada factor, con lo que obtendremos todos los divisores de cNúmero
'--------------------------------------------------------------------------------------------------------------
'Averiguar la cantidad de divisores de cNúmero
iCantidadDivisores = 1
For N = LBound(mtrN) To UBound(mtrN)
iCantidadDivisores = iCantidadDivisores * (mtrE(N) + 1)
Next N
'Calcular el número de columnas que tendrá que tener la matriz de divisores, el cual será el número de potencias _
del divisor más pequeño (incluyendo la potencia 0)
iColumnasMtrDivisores = mtrE(1) + 1
'Redimensionar la matriz que contendrá los divisores
ReDim curMtrDivisores(iCantidadDivisores / iColumnasMtrDivisores, iColumnasMtrDivisores)
'Llenar la 1ª fila de la matriz
For N = 0 To mtrE(1)
curMtrDivisores(1, N + 1) = mtrN(1) ^ N
Next N
iFila = 1 'iFila controla cual es la última fila con datos de curMtrDivisores
'Proceso
iFilaReal = 2
For iPrimo = 2 To UBound(mtrN)
For N = 1 To mtrE(iPrimo)
ReDim curMtrTrabajo(iFila, iColumnasMtrDivisores)
For j = 1 To UBound(curMtrTrabajo)
For iColumna = 1 To iColumnasMtrDivisores
curMtrTrabajo(j, iColumna) = curMtrDivisores(j, iColumna) * (mtrN(iPrimo) ^ N)
Next iColumna
Next j
For j = 1 To UBound(curMtrTrabajo)
For iColumna = 1 To iColumnasMtrDivisores
curMtrDivisores(iFilaReal, iColumna) = curMtrTrabajo(j, iColumna)
Next iColumna
iFilaReal = iFilaReal + 1
Next j
Next N
iFila = iFila + (iFila * mtrE(iPrimo))
Next iPrimo
'Devolver la lista de los divisores
If Not blnOrdenar Then
For iFila = 1 To iCantidadDivisores / iColumnasMtrDivisores
For iColumna = 1 To iColumnasMtrDivisores
ListaDivisores = ListaDivisores & Application.International(xlListSeparator) & CStr(curMtrDivisores(iFila, iColumna))
'ListaDivisores = ListaDivisores & "+" & CStr(curMtrDivisores(iFila, iColumna))
Next iColumna
Next iFila
Else
'Crear una matriz de una dimensión en la que poner todos los divisores, para poder ordenarlos
Dim curMtr_a_Ordenar() As Currency, iElemento As Integer
ReDim curMtr_a_Ordenar(1 To UBound(curMtrDivisores) * iColumnasMtrDivisores)
iElemento = 1
For iFila = 1 To UBound(curMtrDivisores)
For iColumna = 1 To iColumnasMtrDivisores
curMtr_a_Ordenar(iElemento) = curMtrDivisores(iFila, iColumna)
iElemento = iElemento + 1
Next iColumna
Next iFila
'Ordenar la matriz
Dim iBucle As Integer, blnOrdenado As Boolean, curCambio As Currency
Do
blnOrdenado = True
For iBucle = 1 To UBound(curMtr_a_Ordenar) - 1
If curMtr_a_Ordenar(iBucle) > curMtr_a_Ordenar(iBucle + 1) Then
curCambio = curMtr_a_Ordenar(iBucle)
curMtr_a_Ordenar(iBucle) = curMtr_a_Ordenar(iBucle + 1)
curMtr_a_Ordenar(iBucle + 1) = curCambio
blnOrdenado = False
Exit For
End If
Next iBucle
If blnOrdenado Then Exit Do
Loop
'Preparar lista de divisores
For iFila = 1 To UBound(curMtr_a_Ordenar)
ListaDivisores = ListaDivisores & Application.International(xlListSeparator) & CStr(curMtr_a_Ordenar(iFila))
Next iFila
End If
'Salir
ListaDivisores = Right(ListaDivisores, Len(ListaDivisores) - 1)
End Function
Hay disponibie un libro de ejemplo de estas funciones, en el que también se encuentra el código de la función para contar el número de divisores de un entero (CuentaDivisores), que no se muestra aquí por ser muy similar a la expuesta para sumarlos.