MaxArrSiConjunto

Esta función nos permite obtener el valor máximo de un rango con distintas condiciones. Sería algo parecido a la función sumar.si.conjunto, pero el resultado final es el valor máximo del rango. La particularidad de esta función es que te permite acceder al valor máximo (primer máximo, segundo máximo, tercer máximo)

=MaxArrSiConjunto([1];[2];[3′];[4′];[3”];[4”]…..)

[1]: Rango de valores que queremos encontrar el valor máximo

[2]: Posición del array (1: pirmer máximo, 2: segundo máximo….)

[3′]: Rango que tienen las condiciones

[4′]: Condición

[3”]: Segundo Rango que tienen las condiciones

[4”]: Segunda Condición

…… Tantos rangos y condiciones como quieras

Public Function MaxArrSiConjunto(Unico As Range, Pos As Integer, ParamArray prms() As Variant) As Variant
    '=MaxSiConjunto([1];[2'];[3'];[2''];[3''].....)
       '[1]: Rango de valores que queremos contar sin repetidos
       '[2]: Posición del array (1: pirmer máximo, 2: segundo máximo....)
       '[3']: Rango que tienen las condiciones
       '[4']: Condición
       '[5'']: Segundo Rango que tienen las condiciones
       '[6'']: Segunda Condición
       '...... Tantos rangos y condiciones como quieras
 
       'abelorteu@informaticaea.com
    Dim filaInit As Long
    Dim filaFinal As Long
    Dim Condicion As Boolean
    Dim i As Integer
 
    Dim col As New Collection
    Dim colSort As New Collection
    Dim varElement As Variant
 
    filaInit = Unico.Row
    filaFinal = filaInit + Unico.Count - 1
 
    Dim x As Variant
    x = (UBound(prms) + 1) / 2
    If (x = Int(x)) Then
        On Error Resume Next
        For i = 1 To filaFinal - filaInit + 1
            Condicion = True
            For a = 1 To x
                If (UCase(Trim(prms(a * 2 - 2)(i))) <> UCase(Trim(prms(a * 2 - 1)))) Then
                    Condicion = False
                End If
            Next a
            If (Condicion) Then
                col.Add Item:=CStr(CLng(Unico(i))), Key:=CStr(CLng(Unico(i)))
            End If
        Next i
 
        Set colSort = fnVarBubbleSort(col, False)
 
        i = 1
        MaxArrSiConjunto = "#NoValue"
        For Each varElement In colSort
            If i = Pos Then
                'Debug.Print varElement
                MaxArrSiConjunto = CLng(varElement)
            End If
            i = i + 1
        Next varElement
    Else
       MaxArrSiConjunto = "#ERROR"
    End If
End Function
 
Public Function fnVarBubbleSort(ByRef colInput As Collection, Optional bAsc = True) As Collection
 
    Dim varTemp                 As Variant
    Dim lngCounter              As Long
    Dim lngCounter2             As Long
 
    For lngCounter = 1 To colInput.Count - 1
        For lngCounter2 = lngCounter + 1 To colInput.Count
            Select Case bAsc
            Case True:
                If colInput(lngCounter) > colInput(lngCounter2) Then
                    varTemp = colInput(lngCounter2)
                    colInput.Remove lngCounter2
                    colInput.Add varTemp, varTemp, lngCounter
                End If
 
            Case False:
                If colInput(lngCounter) < colInput(lngCounter2) Then
                    varTemp = colInput(lngCounter2)
                    colInput.Remove lngCounter2
                    colInput.Add varTemp, varTemp, lngCounter
                End If
            End Select
        Next lngCounter2
    Next lngCounter
 
    Set fnVarBubbleSort = colInput
 
End Function

MaxSiConjunto

Esta función nos permite obtener el valor máximo de un rango con distintas condiciones. Sería algo parecido a la función sumar.si.conjunto, pero el resultado final es el valor máximo del rango.

=MaxSiConjunto([1];[2′];[3′];[2”];[3”]…..)

[1]: Rango de valores que queremos encontrar el valor máximo/p>

[2′]: Rango que tienen las condiciones

[3′]: Condición

[2”]: Segundo Rango que tienen las condiciones

[3”]: Segunda Condición ‘…… Tantos rangos y condiciones como quieras

Public Function MaxSiConjunto(ValMax As Range, ParamArray prms() As Variant) As Variant
 
    '=MaxSiConjunto([1];[2'];[3'];[2''];[3''].....)
       '[1]: Rango de valores que queremos encontrar el valor máximo
       '[2']: Rango que tienen las condiciones
       '[3']: Condición
       '[2'']: Segundo Rango que tienen las condiciones
       '[3'']: Segunda Condición
       '...... Tantos rangos y condiciones como quieras
 
       'abelorteu@informaticaea.com
 
    Dim filaInit As Long
    Dim filaFinal As Long
    Dim Condicion As Boolean
    Dim MAX As Variant
 
 
    filaInit = ValMax.Row
    filaFinal = filaInit + ValMax.Count - 1
    Dim x As Variant
    x = (UBound(prms) + 1) / 2
    MAX = "#ERROR"
    If (x = Int(x)) Then
        On Error Resume Next
        MAX = "#ERROR"
        For i = 1 To filaFinal - filaInit + 1
            Condicion = True
            For a = 1 To x
                If (UCase(Trim(prms(a * 2 - 2)(i))) <> UCase(Trim(prms(a * 2 - 1)))) Then
                    Condicion = False
                End If
            Next a
            If Condicion Then
                If (CLng(ValMax(i)) > CLng(MAX)) Then
                    MAX = CLng(ValMax(i))
                End If
            End If
        Next i
    End If
    MaxSiConjunto = MAX
End Function

MinSiConjunto

Esta función nos permite obtener el valor mínimo de un rango con distintas condiciones. Sería algo parecido a la función sumar.si.conjunto, pero el resultado final es el valor mínimo del rango.

=MinSiConjunto([1];[2′];[3′];[2”];[3”]…..)

[1]: Rango de valores que queremos encontrar el valor mínimo

[2′]: Rango que tienen las condiciones

[3′]: Condición

[2”]: Segundo Rango que tienen las condiciones

[3”]: Segunda Condición ‘…… Tantos rangos y condiciones como quieras

Public Function MinSiConjunto(ValMin As Range, ParamArray prms() As Variant) As Variant
    '=MinSiConjunto([1];[2'];[3'];[2''];[3''].....)
       '[1]: Rango de valores que queremos encontrar el valor minimo
       '[2']: Rango que tienen las condiciones
       '[3']: Condición
       '[2'']: Segundo Rango que tienen las condiciones
       '[3'']: Segunda Condición
       '...... Tantos rangos y condiciones como quieras
 
       'abelorteu@informaticaea.com
 
 
    Dim filaInit As Long
    Dim filaFinal As Long
    Dim Condicion As Boolean
    Dim MIN As Variant
 
 
    filaInit = ValMin.Row
    filaFinal = filaInit + ValMin.Count - 1
    Dim x As Variant
    x = (UBound(prms) + 1) / 2
    MIN = "#ERROR"
    If (x = Int(x)) Then
        On Error Resume Next
        MIN = "#ERROR"
        For i = 1 To filaFinal - filaInit + 1
            Condicion = True
            For a = 1 To x
                If (UCase(Trim(prms(a * 2 - 2)(i))) <> UCase(Trim(prms(a * 2 - 1)))) Then
                    Condicion = False
                End If
            Next a
            If Condicion Then
                If (CLng(ValMin(i)) < CLng(MIN)) Then
                    MIN = CLng(ValMin(i))
                End If
            End If
        Next i
    End If
    MinSiConjunto = MIN
End Function

Collection VBA

Los tipos de datos Collection en algunos libros de informática se denominan diccionario que es una tabla de elementos en la que puedes buscar una entrada usando una clave.

En Visual Basic los datos Collection. Presentan las siguientes características:

  • Habilita almacenar elementos relacionados
  • Proporciona los métodos Add, Remove, Item y la propiedad Count
Dim dict As New Collection
 
dict.Add Item:="Valor 1", Key:="Key 1"
dict.Add Item:="Valor 2", Key:="Key 2"
dict.Add Item:="Valor 3", Key:="Key 3"
dict.Add Item:="Valor 4", Key:="Key 4"

Si queremos acceder a un elemento a partir de la clave

Debug.Print (dict("Key 2"))
'Valor 2

Si queremos listar toda la matriz

Dim K As Variant
For Each K In dict.Keys
    debug.print "Key: " &amp; K , "Value: " &amp; dict.Item(K)
Next

Pegar imagen en una celda

Para pegar una imagen que tenemos en el porta papeles en una celda de Excel seleccionada, utilizaremos la siguiente macro:

Sub PegarFoto()
    ActiveSheet.Paste 'Pegamos del portapapeles
    ActiveSheet.Select
    With Selection
        .ShapeRange.LockAspectRatio = msoFalse
        .ShapeRange.Height = 175 'Alto de la imagen
        .ShapeRange.Width = 205 'Ancho de la imagen
        .ShapeRange.Left = .ShapeRange.Left + 1 'Añadimos 1 para que se vea la línea divisoria de la celda (izquierda)
        .ShapeRange.Top = .ShapeRange.Top + 1 'Añadimos 1 para que se vea la línea divisoria de la celda (superior)
    End With
End Sub

Descargar archivos adjuntos correo

Outlook tiene la opción de descargar todos los archivos adjuntos de un correo, pero no se puede hacer de una selección de correos.

Podemos :

Sub DescargarArchivos()
    Dim adjunto As Attachment
    Dim Ruta As String
    Dim NombreArchivo As String
    Dim i As Integer
    Dim seleccion As Outlook.MailItem
    Ruta = BrowseForFolder("C:/")
    For Each seleccion In Application.ActiveExplorer.Selection
        For Each adjunto In seleccion.Attachments
            'filtramos sólo los archivos con extensión excel, este condicional se puede quitar o añadir extensiones
            If ((InStr(adjunto.DisplayName, ".xlsb") Or InStr(adjunto.DisplayName, ".xlsx") Or InStr(adjunto.DisplayName, ".xls") Or InStr(adjunto.DisplayName, ".xlsm"))) Then
                NombreArchivo = Ruta &amp; adjunto.FileName
                adjunto.SaveAsFile NombreArchivo
            End If
        Next adjunto
    Next seleccion
End Sub
 
 
Function BrowseForFolder(strStartingFolder As Variant) As String
    Const WINDOW_HANDLE = 0
    Const NO_OPTIONS = 0
    Dim objShell As Object, _
        objFolder As Object, _
        objFolderItem As Object
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, "Select a folder:", NO_OPTIONS, strStartingFolder)
    If Not TypeName(objFolder) = "Nothing" Then
        Set objFolderItem = objFolder.self
        BrowseForFolder = objFolderItem.Path &amp; "\"
    Else
        BrowseForFolder = ""
    End If
    Set objFolderItem = Nothing
    Set objFolder = Nothing
    Set objShell = Nothing
End Function

Para crear un Script:

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\Users\"
     For Each objAtt In itm.Attachments
          objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
          Set objAtt = Nothing
     Next
End Sub

Contar único VBA

Esta función permite contar valores únicos de un rango, con una condición de otro rango. Sería algo parecido a la funcion contar.si, pero el resultado final son valores únicos.

=ContarUnico([1];[2];[3])

[1]: Rango de valores que queremos contar sin repetidos

[2]: Rango que tienen las condiciones

[3]: Condición

Captura

Public Function ContarUnico(rng As Range) As Long
   'abelorteu@informaticaea.com
 
    Dim col As New Collection
    Dim cel As Range
    On Error Resume Next
    For Each cel In rng
        col.Add Item:=CStr(cel.Value), Key:=CStr(cel.Value)
    Next cel
    ContarUnico = col.Count
End Function
 
Public Function ContarUnicoSi(Unico As Range, Range1 As Range, Valor As Variant) As Long
       '=ContarUnicoSi([1];[2];[3])
       '[1]: Rango de valores que queremos contar sin repetidos
       '[2]: Rango que tienen las condiciones
       '[3]: Condición
 
       'abelorteu@informaticaea.com
    Dim filaInit As Long
    Dim filaFinal As Long
 
    Dim col As New Collection
 
    filaInit = Range1.Row
    filaFinal = filaInit + Range1.Rows.Count - 1
 
    On Error Resume Next
    For i = 1 To filaFinal - filaInit + 1
        If (UCase(Trim(Range1(i).Value)) = UCase(Trim(Valor))) Then
            col.Add Item:=CStr(Unico(i).Value), Key:=CStr(Unico(i).Value)
        End If
    Next
 
    If (arrDic.Count = 0) Then
        ContarUnicoSi = col.Count
    Else
        ContarUnicoSi = col.Count - 1
    End If
End Function
 
Public Function ContarUnicoSiConjunto(Unico As Range, ParamArray prms() As Variant) As Variant
    '=ContarUnicoSiConjunto([1];[2'];[3'];[2''];[3''].....)
       '[1]: Rango de valores que queremos contar sin repetidos
       '[2']: Rango que tienen las condiciones
       '[3']: Condición
       '[2'']: Segundo Rango que tienen las condiciones
       '[3'']: Segunda Condición
       '...... Tantos rangos y condiciones como quieras
 
       'abelorteu@informaticaea.com
    Dim filaInit As Long
    Dim filaFinal As Long
    Dim Condicion As Boolean
 
    Dim col As New Collection
 
    filaInit = Unico.Row
    filaFinal = filaInit + Unico.Count - 1
    Dim x As Variant
    x = (UBound(prms) + 1) / 2
    If (x = Int(x)) Then
        On Error Resume Next
        For i = 1 To filaFinal - filaInit + 1
            Condicion = True
            For a = 1 To x
                If (UCase(Trim(prms(a * 2 - 2)(i))) <> UCase(Trim(prms(a * 2 - 1)))) Then
                    Condicion = False
                End If
            Next a
            If (Condicion) Then
                col.Add Item:=CStr(Unico(i)), Key:=CStr(Unico(i))
                Debug.Print Unico(i)
            End If
        Next i
 
        If (arrDic.Count = 0) Then
            ContarUnicoSiConjunto = col.Count
        Else
            ContarUnicoSiConjunto = col.Count - 1
        End If
    Else
       ContarUnicoSiConjunto = "#ERROR"
    End If
End Function

Funciones para trabajar con archivos

Funciones para trabajar con archivos

Sub MostrarRutaArchivo()
'Mostramos la ruta del archivo actual.
MsgBox ThisWorkbook.Path
 
End Sub
Sub CrearDirectorio()
'Creamos una caroeta en el escritorio
MkDir "C:\Users\Usuario\Desktop\NombreNuevaCarpeta"
 
End Sub
Sub CopiarArchivo()
'Copiamos archivo a la carpeta Nuevo
FileCopy "C:\Users\Usuario\Desktop\Archivo.xlsx", "C:\Users\Usuario\Desktop\Nuevo\Archivo.xlsx"
 
End Sub
Sub EliminarArchivo()
'Eliminamos archivo
Kill "C:\Users\Usuario\Desktop\archivo.xlsx"
 
End Sub
Sub RenombrarArchivo()
'Renombramos archivo
Name "C:\Users\Usuario\Desktop\archivo.xlsx" As "C:\Users\Usuario\Desktop\archivo2.xlsx"
 
End Sub
Sub MoverArchivo()
'Movemos archivo a la carpeta Nuevo
Name "C:\Users\Usuario\Desktop\archivo.xlsx" As "C:\Users\Usuario\Desktop\Nuevo\archivo.xlsx"
 
End Sub

Ordenar array VBA

Este script nos permite oredenar un array de manor a mayor en VBA

Sub BubbleSort(arr)
   ' Ordena de menor a mayor un array
   ' Call BubbleSort(MyArray)
  Dim strTemp As String
  Dim i As Long
  Dim j As Long
  Dim lngMin As Long
  Dim lngMax As Long
  lngMin = LBound(arr)
  lngMax = UBound(arr)
 
   For i = lngMin To lngMax - 1
    For j = i + 1 To lngMax
     If arr(i) &gt; arr(j) Then
       strTemp = arr(i)
       arr(i) = arr(j)
       arr(j) = strTemp
     End If
    Next j
   Next i
End Sub

Estructuras de control o Bucles en VBA

Las estructuras de control permiten la repetición de determinadas acciones.

Uno de los errores más comunes que se producen en la utilización de bucles de este tipo, es la no inicialización de las variables utilizadas como contadores de iteraciones, produciendo un error de no finalización del bucle.

Do… Loop Until

Esta estructura de control se puede usar para ejecutar un bloque de instrucciones un número indefinido de veces. Las instrucciones se repiten hasta que una condición llegue a ser True.

Ejemplo:

Sub Ejemplo1()
  Dim contador As Integer
  Dim numero As Integer
  numero = 9
  Do Until numero = 10
   If numero &lt;= 0 Then Exit Do
     numero = numero – 1
     contador = contador + 1
  Loop
  MsgBox “Se alcanzó el valor ” &amp; numero &amp; ” ” &amp; contador
End Sub

Do While… Loop

En este caso, las instrucciones se repiten mientras una condición sea True (al contrario que con el Do… Loop Until).

Ejemplo:

Sub Ejemplo2()
  Dim Escribir As Integer
  Escribir = 1
  Do While Escribir &lt; 7
    ActiveCell.FormulaR1C1 = “Excel”
    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    Cells(lastrow, 1).Offset(1, 0).Select
    Escribir = Escribir + 1
  Loop
End Sub

While … Wend

El bucle WHILE…WEND sirve para realizar un tipo de bucle muy utilizado en programación que es el bucle Mientras, que se ejecuta mientras que se cumpla una condición.

Ejemplo

Sub Ejemplo3()
  dim a As Integer
  a = 0
  While (a &lt; 13)
    a = a + 1
  End While
  MsgBox “Se alcanzó el valor ” &amp; a 
End Sub

For… To… Next

El bucle FOR NEXT nos permite repetir una acción un número de veces dado.

Ejemplo:

En este ejemplo tenemos el bucle FOR NEXT en VBA más sencillo. El bucle cuenta de 1 a 10 y va poniendo en una columna el valor del contador.

Sub Ejemplo4()
  dim fila As Integer
  For CONTADOR = 1 To 10
    fila = CONTADOR
    Cells(fila, 1) = CONTADOR
  Next
End Sub

With

La estructura With en Vba nos permite ejecutar un conjunto de instrucciones sin tener que volver a hacer referencia al mismo objeto.

Sub Ejemplo5()
  With Cells(1, 1)
   .Value = “Hola informaticaea.com”
   .Font.Bold = True
  End With
End Sub