PROCEDIMIENTOS Y FUNCIONES VBA

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
     

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
     

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

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
 

Public Sub EnviarHojaPorCorreoElectrónico()
    ActiveSheet.Copy
    ActiveWorkbook.SendMail Recipients:="dirección@dominio", Subject:="Envío libro de Excel"
    ActiveWorkbook.Close savechanges:=False
End Sub
 

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
 

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

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

 

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
 

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
 

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

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
 

Este código tendría que situarse en el módulo del formulario.

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

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

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

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

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

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

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