PROCEDIMIENTOS Y FUNCIONES VBA

 

Página inicial

 

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 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:

 
Public 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:

 
Public 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.

 

Nota: la propiedad FileSearch fue eliminada en Excel 2007, así que este código no funcionará ni en dicha versión ni en la 2010.

 

Procedimiento para listar en una hoja todos los ficheros de un directorio y sus subdirectorios

Notas:

 

Public wksH As Worksheet

Public lngContFila As Long

 

Public 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:

 

Public 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:

 

Public 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:

 

Public 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\Export
Normalmente, dichos tipos suelen ser GIF, JPG y BMP
 
Public 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.

  

Public 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:

 

Public 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.

 

Public 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.

 

Public 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 las celdas combinadas de Hoja1 al editarlas.

 

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:

 

Public 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" & Cstr(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. Utilizando este mismo método es posible crear aleatoriamente una quiniela (la jugada en España) para la que se hayan preestablecido el número de unos, equis y doses que debe tener la apuesta: libro de ejemplo.

 

 

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:

 

Public 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. El código crea el tamiz o criba de Eratóstenes.

Public 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
    Dim lMaxFila As Long
    
    lTope = 1000000 'Asignar a la variable lTope el número máximo al que se _
                     quiera llegar en la búsqueda de números primos.
    ReDim a(1 To lTope)
    lFila = 2
    btCol = 1
    lMaxFila = IIf(CDbl(Replace(Application.Version, ".", Application.International(xlDecimalSeparator))) >= 12, 1048577, 65537)
 
    '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 = lMaxFila 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

 

Public Function EsPrimo(ByVal dNúmero As Double) As Boolean
    'Sintaxis: =EsPrimo(celda o número)
    'Nota: el entero más alto que puede procesar esta función es (en teoría) el límite de la _
     precisión numérica máxima de Excel (999.999.999.999.999)
   
    If (Residuo(dNúmero, 2) = 0 And dNúmero <> 2) Or _
       (Residuo(dNúmero, 3) = 0 And dNúmero <> 3) Or _
       (Residuo(dNúmero, 5) = 0 And dNúmero <> 5) Then _
           Exit Function
     
    Dim dDivisor As Double
    dDivisor = 7
   
    While dDivisor <= Sqr(dNúmero) + 1
        If Residuo(dNúmero, dDivisor) = 0 Then Exit Function
        dDivisor = dDivisor + IIf(Right(CStr(dDivisor), 1) = 3, 4, 2)
    Wend
   
    EsPrimo = True
End Function

 

Private Function Residuo(ByVal cNumerador As Double, ByVal cDenominador As Double) As Double
    '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

 

 

Utilizando el tipo de datos Decimal es posible superar el límite de la precisión numérica de Excel, aunque aviso de que el proceso para calcular números grandes puede llevar bastante tiempo. Valga la siguiente tablita como ejemplo:

 

Número primo Longitud  Tiempo de proceso
535006138814359 15 0:00:18
4847464544434241 16 0:00:54
55350776431903243 17 0:03:03
496481100121144169 18 0:09:12
6082394749206781697 19 0:32:19

 

Cada nuevo dígito significa, aproximadamente, triplicar el tiempo de proceso, de forma que para el caso de un número primo de 29 dígitos dicho tiempo de proceso sería (para el PC de estos ejemplos) de aproximadamente 24.000 horas, lo que equivale a unos dos años y nueve meses...

 

Así que yo me limito a transcribir el código, y que cada cual lo utilice o no como le convenga:

 

Public Function EsPrimoD(vNúmero As Variant) As Boolean
    'Sintaxis: =EsPrimoD(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 Decimal (un entero de 29 dígitos), pero los tiempos de proceso para _
     enteros de más de 19 dígitos son prácticamente inasumibles.

    If (ResiduoD(vNúmero, 2) = 0 And vNúmero <> 2) Or _
       (ResiduoD(vNúmero, 3) = 0 And vNúmero <> 3) Or _
       (ResiduoD(vNúmero, 5) = 0 And vNúmero <> 5) Then _
           Exit Function
      
    Dim vDivisor As Variant
    vNúmero = CDec(vNúmero)
    vDivisor = CDec(7)
    
    While vDivisor <= Sqr(vNúmero) + 1
        If ResiduoD(vNúmero, vDivisor) = 0 Then Exit Function
        vDivisor = vDivisor + IIf(Right(vDivisor, 1) = 3, 4, 2)
    Wend
    
    EsPrimoD = True
End Function

Private Function ResiduoD(vNumerador As Variant, vDenominador As Variant) As Variant
    '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 restos "a mano".
     vNumerador = CDec(vNumerador)
     vDenominador = CDec(vDenominador)
    ResiduoD = CDec(vNumerador - vDenominador * Int(vNumerador / vDenominador))
End Function

 

Si se desea averiguar si un número con más de 15 dígitos es primo habría que encerrarlo entre comillas al llamar a la función, puesto que de no hacerse así Excel convertiría en ceros los dígitos a partir del 15º. Es decir, para averiguar si por ejemplo el 1.238.926.361.552.897 (16 dígitos) es o no primo (que lo es), la sintaxis sería:

 

=EsPrimoD("1238926361552897")

 

Nota: en este enlace hay una pequeña monografía sobre unas fórmulas para averiguar si un número es o no primo usando sólo funciones de hoja de cálculo.

 

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 2012 es 22 · 503.

Lógicamente, un número primo no puede descomponerse.


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 de la precisión numérica de Excel, esto  es 999.999.999.999.999, 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 dNúmero As Double) 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 de la _
     precisión numérica máxima de Excel (999.999.999.999.999), pero los cálculos necesarios _
     para números tan grandes pueden llevar bastante tiempo.
     
    If dNúmero > 999999999999999# Then
       DescFact = "El número más alto que puede procesar la función DescFact es 999.999.999.999.999"
       Exit Function
    End If
    
    If Int(dNúmero) <> dNúmero Then
       DescFact = "El número a procesar debe ser un entero."
       Exit Function
    End If
     
    'Si el número pasado como argumento a la función es primo, terminar
    If EsPrimo(dNúmero) Then
        DescFact = "=" & CStr(dNúmero)
        Exit Function
    End If
    
    'Variables
    Dim mtrN() As Double, mtrE() As Byte
    Dim dTope As Double, dProcesando As Double, dDivisor As Double
    Dim n As Double
    
    'Inicializaciones
    DescFact = "="
    dProcesando = dNúmero
    dTope = 1
    dDivisor = 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, lo que ahorrará un 20% de _
     cálculos, aproximadamente)
    If Residuo(dProcesando, 2) = 0 Then
        ReDim mtrN(dTope): ReDim mtrE(dTope)
        mtrN(dTope) = 2
        While Residuo(dProcesando, 2) = 0
            mtrE(dTope) = mtrE(dTope) + 1
            dProcesando = dProcesando / 2
        Wend
        dTope = dTope + 1
    End If
    
    If Residuo(dProcesando, 3) = 0 Then
        ReDim Preserve mtrN(dTope): ReDim Preserve mtrE(dTope)
        mtrN(dTope) = 3
        While Residuo(dProcesando, 3) = 0
            mtrE(dTope) = mtrE(dTope) + 1
            dProcesando = dProcesando / 3
        Wend
        dTope = dTope + 1
    End If
    
    If Residuo(dProcesando, 5) = 0 Then
        ReDim Preserve mtrN(dTope): ReDim Preserve mtrE(dTope)
        mtrN(dTope) = 5
        While Residuo(dProcesando, 5) = 0
            mtrE(dTope) = mtrE(dTope) + 1
            dProcesando = dProcesando / 5
        Wend
        dTope = dTope + 1
    End If
    
    'Si dProcesando = 1, terminar
    If dProcesando = 1 Then GoTo Listar
    
    'Si dProcesando es primo, terminar
    If EsPrimo(dProcesando) Then
        If dTope = 1 Then
            ReDim mtrN(dTope): ReDim mtrE(dTope)
        Else
            ReDim Preserve mtrN(dTope): ReDim Preserve mtrE(dTope)
        End If
        mtrN(dTope) = dProcesando: mtrE(dTope) = 1
        GoTo Listar
    End If
    
    'Bucle principal
    While dProcesando > 1
        If Residuo(dProcesando, dDivisor) = 0 Then
            If EsPrimo(dDivisor) Then
                While Residuo(dProcesando, dDivisor) = 0
                    ReDim Preserve mtrN(dTope): ReDim Preserve mtrE(dTope)
                    mtrN(dTope) = dDivisor: mtrE(dTope) = mtrE(dTope) + 1
                    dProcesando = dProcesando / dDivisor
                Wend
                dTope = dTope + 1
            End If
            If dProcesando = 1 Then GoTo Listar
            'Si dProcesando es primo, terminar
            If EsPrimo(dProcesando) Then
                ReDim Preserve mtrN(dTope): ReDim Preserve mtrE(dTope)
                mtrN(dTope) = dProcesando: mtrE(dTope) = 1
                GoTo Listar
            End If
        End If
        dDivisor = dDivisor + IIf(Right(CStr(dDivisor), 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 = Replace(Left(DescFact, Len(DescFact) - 1), "0^0*", "")
    
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 dNúmero As Double, Optional blIncluirNúmero As Boolean = True) As Double
    '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 _
     double (999.999.999.999.999). Si la suma de los divisores de dNúmero es mayor, se producirá un error.
     
    'Si dNúmero = 1, terminar
    If dNúmero = 1 Then
        SumaDivisores = 0 + IIf(blIncluirNúmero, dNúmero, 0)
        Exit Function
    End If
     
    'Si el número pasado como argumento a la función es primo, terminar
    If EsPrimo(dNúmero) Then
        SumaDivisores = 1 + IIf(blIncluirNúmero, dNúmero, 0)
        Exit Function
    End If
    
    'Variables
    Dim mtrN() As Double, mtrE() As Byte
    Dim dTope As Double, dProcesando As Double, dDivisor As Double
    Dim N As Double
    
    'Inicializaciones
    SumaDivisores = 1
    dProcesando = dNúmero
    dTope = 1
    dDivisor = 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(dProcesando, 2) = 0 Then
        ReDim mtrN(dTope): ReDim mtrE(dTope)
        mtrN(dTope) = 2
        While Residuo(dProcesando, 2) = 0
            mtrE(dTope) = mtrE(dTope) + 1
            dProcesando = dProcesando / 2
        Wend
        dTope = dTope + 1
    End If
    
    If Residuo(dProcesando, 3) = 0 Then
        ReDim Preserve mtrN(dTope): ReDim Preserve mtrE(dTope)
        mtrN(dTope) = 3
        While Residuo(dProcesando, 3) = 0
            mtrE(dTope) = mtrE(dTope) + 1
            dProcesando = dProcesando / 3
        Wend
        dTope = dTope + 1
    End If
    
    If Residuo(dProcesando, 5) = 0 Then
        ReDim Preserve mtrN(dTope): ReDim Preserve mtrE(dTope)
        mtrN(dTope) = 5
        While Residuo(dProcesando, 5) = 0
            mtrE(dTope) = mtrE(dTope) + 1
            dProcesando = dProcesando / 5
        Wend
        dTope = dTope + 1
    End If
    
    'Si dProcesando = 1, terminar
    If dProcesando = 1 Then GoTo Cálculo
    
    'Si dProcesando es primo, terminar
    If EsPrimo(dProcesando) Then
        If dTope = 1 Then
            ReDim mtrN(dTope): ReDim mtrE(dTope)
        Else
            ReDim Preserve mtrN(dTope): ReDim Preserve mtrE(dTope)
        End If
        mtrN(dTope) = dProcesando: mtrE(dTope) = 1
        GoTo Cálculo
    End If
    
    'Bucle principal
    While dProcesando > 1
        If Residuo(dProcesando, dDivisor) = 0 Then
            If EsPrimo(dDivisor) Then
                While Residuo(dProcesando, dDivisor) = 0
                    ReDim Preserve mtrN(dTope): ReDim Preserve mtrE(dTope)
                    mtrN(dTope) = dDivisor: mtrE(dTope) = mtrE(dTope) + 1
                    dProcesando = dProcesando / dDivisor
                Wend
                dTope = dTope + 1
            End If
            If dProcesando = 1 Then GoTo Cálculo
            If (dProcesando < Sqr(dNúmero)) And dProcesando > 1 Then
                ReDim Preserve mtrN(dTope): ReDim Preserve mtrE(dTope)
                mtrN(dTope) = dProcesando: mtrE(dTope) = 1
                GoTo Cálculo
            End If
            'Si dProcesando es primo, terminar
            If EsPrimo(dProcesando) Then
                ReDim Preserve mtrN(dTope): ReDim Preserve mtrE(dTope)
                mtrN(dTope) = dProcesando: mtrE(dTope) = 1
                GoTo Cálculo
            End If
        End If
        dDivisor = dDivisor + IIf(Right(CStr(dDivisor), 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 - dNú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 programar 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étodo más común, que consiste en dividir el entero a procesar entre todos los números desde 2 hasta dicho entero/2. El código es:

 

Option Base 1
Public Function ListaDivisores(ByVal dNúmero As Double, 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 _
     double (999.999.999.999.999). También se producirá un error si la suma de los divisores _
     del número a procesar excede dicho límite.
     
     If dNú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(dNúmero) Then
        ListaDivisores = "1" & Application.International(xlListSeparator) & CStr(dNúmero)
        Exit Function
    End If
    
    'Variables
    Dim mtrN() As Double, mtrE() As Byte
    Dim dTope As Double, dProcesando As Double, dDivisor As Double
    Dim iCantidadDivisores As Integer, dMtrDivisores() As Double, iColumnasMtrDivisores As Integer
    Dim N As Integer, iFila As Integer, iColumna As Integer, j As Integer, k As Integer
    Dim dMtrTrabajo() As Double, iFilaReal As Integer, iPrimo As Integer
    
    'Inicializaciones
    dProcesando = dNúmero
    dTope = 1
    dDivisor = 7
    
    'Lo primero que hay que hacer es obtener la descomposición factorial de dNú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(dProcesando, 2) = 0 Then
        ReDim mtrN(dTope): ReDim mtrE(dTope)
        mtrN(dTope) = 2
        While Residuo(dProcesando, 2) = 0
            mtrE(dTope) = mtrE(dTope) + 1
            dProcesando = dProcesando / 2
        Wend
        dTope = dTope + 1
    End If
    
    If Residuo(dProcesando, 3) = 0 Then
        ReDim Preserve mtrN(dTope): ReDim Preserve mtrE(dTope)
        mtrN(dTope) = 3
        While Residuo(dProcesando, 3) = 0
            mtrE(dTope) = mtrE(dTope) + 1
            dProcesando = dProcesando / 3
        Wend
        dTope = dTope + 1
    End If
    
    If Residuo(dProcesando, 5) = 0 Then
        ReDim Preserve mtrN(dTope): ReDim Preserve mtrE(dTope)
        mtrN(dTope) = 5
        While Residuo(dProcesando, 5) = 0
            mtrE(dTope) = mtrE(dTope) + 1
            dProcesando = dProcesando / 5
        Wend
        dTope = dTope + 1
    End If
    
    'Si dProcesando = 1, terminar
    If dProcesando = 1 Then GoTo CrearListaDivisores
    
    'Si dProcesando es primo, terminar
    If EsPrimo(dProcesando) Then
        If dTope = 1 Then
            ReDim mtrN(dTope): ReDim mtrE(dTope)
        Else
            ReDim Preserve mtrN(dTope): ReDim Preserve mtrE(dTope)
        End If
        mtrN(dTope) = dProcesando: mtrE(dTope) = 1
        GoTo CrearListaDivisores
    End If
    
    'Bucle principal
    While dProcesando > 1
        If Residuo(dProcesando, dDivisor) = 0 Then
            If EsPrimo(dDivisor) Then
                While Residuo(dProcesando, dDivisor) = 0
                    ReDim Preserve mtrN(dTope): ReDim Preserve mtrE(dTope)
                    mtrN(dTope) = dDivisor: mtrE(dTope) = mtrE(dTope) + 1
                    dProcesando = dProcesando / dDivisor
                Wend
                dTope = dTope + 1
            End If
            If dProcesando = 1 Then GoTo CrearListaDivisores
            If (dProcesando < Sqr(dNúmero)) And dProcesando > 1 Then
                ReDim Preserve mtrN(dTope): ReDim Preserve mtrE(dTope)
                mtrN(dTope) = dProcesando: mtrE(dTope) = 1
                GoTo CrearListaDivisores
            End If
            'Si dProcesando es primo, terminar
            If EsPrimo(dProcesando) Then
                ReDim Preserve mtrN(dTope): ReDim Preserve mtrE(dTope)
                mtrN(dTope) = dProcesando: mtrE(dTope) = 1
                GoTo CrearListaDivisores
            End If
        End If
        dDivisor = dDivisor + IIf(Right(CStr(dDivisor), 1) = 3, 4, 2)
    Wend
    
CrearListaDivisores:
    'Al llegar aquí, tendremos dos matrices: _
      - mtrN(), que contiene los factores primos de dNúmero, y _
      - mtrE(), que contiene sus exponentes _
     Ahora hay que desarrollar las potencias de cada factor, con lo que obtendremos todos los divisores de dNúmero
    '--------------------------------------------------------------------------------------------------------------
    
    'Averiguar la cantidad de divisores de dNú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 su potencia 0)
    iColumnasMtrDivisores = mtrE(1) + 1
    
    'Redimensionar la matriz que contendrá los divisores
    ReDim dMtrDivisores(iCantidadDivisores / iColumnasMtrDivisores, iColumnasMtrDivisores)
    
    'Llenar la 1ª fila de la matriz
    For N = 0 To mtrE(1)
        dMtrDivisores(1, N + 1) = mtrN(1) ^ N
    Next N
    
    iFila = 1 'iFila controla cual es la última fila con datos de dMtrDivisores
    
    'Proceso
    iFilaReal = 2
    For iPrimo = 2 To UBound(mtrN)
        For N = 1 To mtrE(iPrimo)
            ReDim dMtrTrabajo(iFila, iColumnasMtrDivisores)
            For j = 1 To UBound(dMtrTrabajo)
                For iColumna = 1 To iColumnasMtrDivisores
                    dMtrTrabajo(j, iColumna) = dMtrDivisores(j, iColumna) * (mtrN(iPrimo) ^ N)
                Next iColumna
            Next j
            For j = 1 To UBound(dMtrTrabajo)
                For iColumna = 1 To iColumnasMtrDivisores
                    dMtrDivisores(iFilaReal, iColumna) = dMtrTrabajo(j, iColumna)
                Next iColumna
                iFilaReal = iFilaReal + 1
            Next j
        Next N
        iFila = iFila + (iFila * mtrE(iPrimo))
    Next iPrimo
    
    'Devolver la lista de los divisores
    '----------------------------------
    
    'Si no se pidió la lista ordenada...
    If Not blnOrdenar Then
        For iFila = 1 To iCantidadDivisores / iColumnasMtrDivisores
            For iColumna = 1 To iColumnasMtrDivisores
                ListaDivisores = ListaDivisores & Application.International(xlListSeparator) & CStr(dMtrDivisores(iFila, iColumna))
                'ListaDivisores = ListaDivisores & "+" & CStr(dMtrDivisores(iFila, iColumna))
            Next iColumna
        Next iFila
    'Si se pidió la lista ordenada...
    Else
        'Crear una matriz de una dimensión en la que poner todos los divisores, para poder ordenarlos
        Dim dMtr_a_Ordenar() As Double, iElemento As Integer
        ReDim dMtr_a_Ordenar(1 To UBound(dMtrDivisores) * iColumnasMtrDivisores)
        iElemento = 1
        For iFila = 1 To UBound(dMtrDivisores)
            For iColumna = 1 To iColumnasMtrDivisores
                dMtr_a_Ordenar(iElemento) = dMtrDivisores(iFila, iColumna)
                iElemento = iElemento + 1
            Next iColumna
        Next iFila
        
        'Ordenar la matriz
        Dim iBucle As Integer, blnOrdenado As Boolean, dCambio As Double
            
        Do
            blnOrdenado = True
            
            For iBucle = 1 To UBound(dMtr_a_Ordenar) - 1
                If dMtr_a_Ordenar(iBucle) > dMtr_a_Ordenar(iBucle + 1) Then
                    dCambio = dMtr_a_Ordenar(iBucle)
                    dMtr_a_Ordenar(iBucle) = dMtr_a_Ordenar(iBucle + 1)
                    dMtr_a_Ordenar(iBucle + 1) = dCambio
                    blnOrdenado = False
                    Exit For
                End If
            Next iBucle
            If blnOrdenado Then Exit Do
        Loop
    
        
        'Preparar la lista de divisores, separándolos con el separador de listas que esté establecido en la _
         configuración regional.
        For iFila = 1 To UBound(dMtr_a_Ordenar)
            ListaDivisores = ListaDivisores & Application.International(xlListSeparator) & CStr(dMtr_a_Ordenar(iFila))
        Next iFila
        
    End If
    
    'Devolver la lista y 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.

 

 

Página inicial