VBA Excel VLookup - Buscar un valor en una base de datos

VBA Excel VLookup - Buscar un valor en una base de datos

   30 noviembre       Luis Reyes

---

La función BuscarV o VLookup (en inglés) es una de las funciones más útiles e importantes de Microsoft Excel.

Generalmente se usa para buscar un valor particular en grandes hojas de datos donde la intervención manual puede ser complicada. 

Para automatizar las tareas se puede incluir en una macro, la cual dejo aquí.

Sub BuscarCodigo()
'Definimos variables
Dim ValorBuscado As Variant, Valor As Variant, RangoBuscar As Range
Valor = Range("A1").value 'celda con el valor buscado
Set RangoBuscar = Range("A10:D232") 'rango donde buscar
ValorBuscado = Application.VLookup(Valor, RangoBuscar, 3, False) 'Queremos la columna 3
'Si no encuentra valor terminamos la macro
    If IsError(ValorBuscado) Then
    Exit Sub 
Else
MsgBox ValorBuscado
End If
End Sub

Descarga el Archivo

Leer Más...

VBA Excel Borrar filas con determinado valor - utilizar la instrucción EntireRow.Delete

VBA Excel Borrar filas con determinado valor - utilizar la instrucción EntireRow.Delete

   29 noviembre       Luis Reyes

---

En algunas ocasiones tenemos la necesidad de borrar algunos registros de una base de datos, y la manera mas sencilla es utilizar una macro.

A continuación les muestro el código para borrar filas dependiendo del valor de una celda.
Para que la macro funcione hay que seguir los siguientes pasos:

1. Abrir el editor Visual Basic para Aplicaciones (VBA).
2. Insertar un módulo.
3. Pegar el siguiente código en el módulo que se inserto:

Sub BorrarFilas()
Filas = Hoja1.Range("A" & Rows.Count).End(xlUp).Row 'determinamos el numero de veces que se va a repetir el bucle
Columna = 1 'indicamos el numero de columna donde buscará el valor
Valor = "Prueba" 'indicamos el valor que tiene que borrar
For i = Filas To 1 Step -1 'Debemos ir desde abajo hacia arriba
If Cells(i, Columna).Value = Valor Then Cells(i, Columna).EntireRow.Delete
Next i
End Sub

Descargar el Archivo

Leer Más...

VBA Excel Crear consultas SQL de Access a Excel

VBA Excel Crear consultas SQL de Access a Excel

   28 noviembre       Luis Reyes

---

En días pasados les compartí una macro para realizar conexiones SQL a bases de datos, hoy les voy a indicar como lo tenemos que hacer utilizando una base de datos de Access,

 Para que la macro funcione hay que seguir los siguientes pasos:

1. Abrir el editor Visual Basic para Aplicaciones (VBA).

2. Insertar un módulo.

3. Agregar la referencia "Microsoft ActiveX Data Objects 2.0 Library" en el menú herramientas del editor VBA, dar click en referencias.

3. Pegar el siguiente código en el módulo que se inserto:

Sub consulta_access()
Dim cn As ADODB.Connection, rs As ADODB.Recordset 'Declaramos las variables para realizar la conexión
Set cn = New ADODB.Connection 'creamos la conexión
    cn.Provider = "Microsoft.ACE.OLEDB.12.0"
    cn.Open "C:\users\Luis Reyes\TU_BASE_DE_DATOS.mdb" 'abrimos la base de Datos
Set rs = New ADODB.Recordset 'Obtenemos los registros de nuestra base de datos
    Sql = "SELECT usuarios FROM correos" 'creamos la consulta SQL
    rs.Source = Sql
    rs.ActiveConnection = cn ' hacemos referencia a nuestra conexión
    rs.Open 'abrimos la consulta
    Hoja1.Range("A2").CopyFromRecordset rs 'destino de nuestra consulta
    If rs.State <> adStateClosed Then
    rs.Close
    End If
    If Not rs Is Nothing Then Set rs = Nothing
    If Not cn Is Nothing Then Set cn = Nothing
Hoja1.Cell(1, 1).Value = "Encabezado 1"
End Sub

4. Reemplazar C:\users\Luis Reyes\TU_BASE_DE_DATOS.mdb por la ruta y el nombre de tu base de datos.

Descarga el Archivo

Leer Más...

VBA EXCEL Macro para enviar correos masivos

VBA EXCEL Macro para enviar correos masivos

   26 noviembre       Luis Reyes

---

En algunas ocasiones tenemos la tarea de enviar correos masivos, gracias a Excel ahora esa tarea es mucho mas sencillo, les comparto una macro para enviar correos masivos, para utilizar esta macro hay seguir los siguientes pasos:

1. Abrir Excel

2. Abrir el Editor de VBA.

3. Pegar el siguiente código:

Sub correo()

      For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
        Set mail = CreateObject("outlook.application").createitem(0)
ruta = cells( i,6).value
cp = ruta
ChDir cp
arch = Dir(ruta & "\*.*")
        mail.To = Range("A" & i) 'Destinatarios
        mail.CC = Range("B" & i) 'Con copia
        mail.Bcc = Range("C" & i) 'Con copia oculta
        mail.Subject = Range("D" & i) '"Asunto"
        mail.body = Range("E" & i) '"Cuerpo del mensaje"
              
Do While arch <> ""
mail.Attachments.Add cp & "\" & arch ' Error
arch = Dir()
Loop

        'mail.send 'El correo se envía en automático
        mail.display 'El correo se muestra
    Next i
    MsgBox "Correos enviados", vbInformation, "SALUDOS"
End Sub

Descarga el archivo

Leer Más...

Crear consultas SQL en Excel

Crear consultas SQL en Excel

   23 noviembre       Luis Reyes

---

Las consultas en SQL son muy importantes, aunque en la actualidad hay muchas herramientas que nos ayudan a crear conexiones SQL,  pero por eficiencia les comparto una macro para realizar las consultas más rápida.
Para que la macro funcione hay que seguir los siguientes pasos:
1. Abrir el editor Visual Basic para Aplicaciones (VBA).
2. Insertar un módulo.
3. Agregar la referencia "Microsoft ActiveX Data Objects 2.0 Library" en el menú herramientas del editor VBA, dar click en referencias.

3. Pegar el siguiente código en el módulo que se inserto:

Sub SQL_Consulta()
    Hoja1.Cells.Clear 'limpiar consultas anteriores
    Dim oCn As ADODB.Connection
    Dim oRS As ADODB.Recordset
    Dim ConnString As String
    Dim SQL As String
    Dim CMDStoredProc As ADODB.Command
    Dim CnnConexion As ADODB.Connection
    Dim RcsDatos As ADODB.Recordset
    Dim CadConexion As String 'Cadena de conexión
    Dim RecordsAffected As Long
    'Cadena de conexión
    Dim Servidor As String
    Dim Usuario As String
    Dim Contrasena As String
    Dim BaseDatos As String

    Servidor = Hoja2.Range("B1")
    Usuario = Hoja2.Range("B3")
    Contrasena = Hoja2.Range("B4")
    BaseDatos = Hoja2.Range("B2").Value
    ' Cadena de conexión
    ConnString = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=" & Usuario & ";Pwd=" & Contrasena & ";Initial Catalog=" & BaseDatos & ";Data Source=" & Servidor & ""
    Set oCn = New ADODB.Connection
    oCn.ConnectionString = ConnString
    oCn.Open
    SQL = Hoja2.Range("B5").Value ' Consulta en SQL
    Set oRS = New ADODB.Recordset
    oRS.Source = SQL
    oRS.ActiveConnection = oCn
    oRS.Open
    Hoja1.Range("A2").CopyFromRecordset oRS ' Hoja de destino
    If oRS.State <> adStateClosed Then
    oRS.Close
    End If

  

    If Not oRS Is Nothing Then Set oRS = Nothing

    If Not oCn Is Nothing Then Set oCn = Nothing

End Sub

Descargar el archivo

Leer Más...

VBA Excel macro para leer XML CFDI 3.3

VBA Excel macro para leer XML CFDI 3.3

   22 noviembre       Luis Reyes

---

Les comparto una macro que he adaptado para leer los XML de los CFDI versión 3.3 de forma masiva.
Para que la macro funcione hay que seguir los siguientes pasos:
1. Abrir el editor Visual Basic para Aplicaciones (VBA).
2. Insertar un módulo.
3. Agregar la referencia "Microsoft XML, v3.0" en el menú herramientas del editor VBA, dar click en referencias.

3. Pegar el siguiente código:

Sub Ruta_CFDI()
'macro para en listar los XML que va a leer
'Adapatado por Luis Reyes
Dim fs, carpeta, archivo, subcarpeta As Object
contador = 2 'determinar en que fila comenzará a colocar la ruta y nombre de los XML
Set fs = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker) 'se obtiene la ruta la carpeta
    If .Show = -1 Then
        ruta = .SelectedItems(1)
        Range("V1").Value = ruta & "\"
    End If
End With
    
    If ruta = "" Then
        Exit Sub
    End If
Set carpeta = fs.GetFolder(ruta)
For Each archivo In carpeta.Files
 If Right(archivo, 4) = ".xml" Then
  Range("AD" & contador).Value = ruta & "\" & archivo.Name
  contador = contador + 1
 End If
 If Right(archivo, 4) = ".XML" Then
  Range("AD" & contador).Value = ruta & "\" & archivo.Name
  contador = contador + 1
 End If
Next
If Application.WorksheetFunction.CountA(Columns(30)) <= 1 Then
MsgBox "No se encontro ningún archivo *.XML" & Chr(10) & ruta, vbCritical, "Importar datos CFDI"
End
End If

Call Lectura_CFDI 'ejecuta la macro que lee los XML
End Sub


Private Sub Lectura_CFDI()
'Adapatado por Luis Reyes
With Application
      .ScreenUpdating = False
      .Calculation = xlCalculationManual
      .EnableEvents = False
      .DisplayStatusBar = False
      
Dim Concepto As String
Dim pctCompl As Single
Set DocumentoXML = New DOMDocument
Set r = Range("AD2").CurrentRegion 'determina apartir de donde comienza a contar
filas = r.Rows.Count

For i = 2 To filas + 6 'número de documentos que va a leer

DocumentoXML.Load ("" & Cells(i, 30) & "")

Set ListaNodo = DocumentoXML.SelectNodes("/cfdi:Comprobante")
On Error Resume Next
For Each Nodo In ListaNodo
    Subtotal = Val(Nodo.Attributes.getNamedItem("SubTotal").Text)
    Fecha = Mid(Nodo.Attributes.getNamedItem("Fecha").Text, 1, 10)
    Serie = Nodo.Attributes.getNamedItem("Serie").Text
    Folio = Serie & " - " & Nodo.Attributes.getNamedItem("Folio").Text
    Total = Val(Nodo.Attributes.getNamedItem("Total").Text)
    Descuento = Val(Nodo.Attributes.getNamedItem("Descuento").Text)
  
Next Nodo
''''''''''''''''''''''''''''''''''''''''''''''''Nombre del emisor'''''''''''''''''''''''''''''''''''''''''''''''''''
Set ListaNodo = DocumentoXML.SelectNodes("/cfdi:Comprobante/cfdi:Emisor")
For Each Nodo In ListaNodo
    Proveedor = Nodo.Attributes.getNamedItem("Nombre").Text
    RFC = Nodo.Attributes.getNamedItem("Rfc").Text
Next Nodo
''''''''''''''''''''''''''''''''''''''''''''''''Conceptos'''''''''''''''''''''''''''''''''''''''''''''''''''
Set ListaNodo = DocumentoXML.SelectNodes("/cfdi:Comprobante/cfdi:Conceptos/cfdi:Concepto")
For Each Nodo In ListaNodo
    Concepto = Concepto & Nodo.Attributes.getNamedItem("Descripcion").Text & " - "
Next Nodo
''''''''''''''''''''''''''''''''''''''''''''''''Impuestos'''''''''''''''''''''''''''''''''''''''''''''''''''
Set ListaNodo = DocumentoXML.SelectNodes("/cfdi:Comprobante/cfdi:Conceptos/cfdi:Concepto/cfdi:Impuestos/cfdi:Traslados/cfdi:Traslado")
For Each Nodo In ListaNodo
    If Nodo.Attributes.getNamedItem("Impuesto").Text = "002" Then
        IVA = IVA + Val(Nodo.Attributes.getNamedItem("Importe").NodeValue)
    End If
    If Nodo.Attributes.getNamedItem("Impuesto").Text = "003" Then
        IEPS = IEPS + Val(Nodo.Attributes.getNamedItem("Importe").NodeValue)
    End If
 Next Nodo
''''''''''''''''''''''''''''''''''''''''''''''''Retenciones'''''''''''''''''''''''''''''''''''''''''''''''''''
Set ListaNodo = DocumentoXML.SelectNodes("/cfdi:Comprobante/cfdi:Conceptos/cfdi:Concepto/cfdi:Impuestos/cfdi:Retenciones/cfdi:Retencion")
For Each Nodo In ListaNodo
    If Nodo.Attributes.getNamedItem("Impuesto").Text = "001" Then
        ISRRe = IVARe + Val(Nodo.Attributes.getNamedItem("Importe").NodeValue)
    End If
    If Nodo.Attributes.getNamedItem("Impuesto").Text = "002" Then
        IVARe = IVARe + Val(Nodo.Attributes.getNamedItem("Importe").NodeValue)
        End If
Next Nodo
'''''''''''''''''''''''''''OTROS IMPUESTOS''''''''''''''''''''''''''''''''''''''''''
Set ListaNodo = DocumentoXML.SelectNodes("cfdi:Comprobante/cfdi:Complemento/implocal:ImpuestosLocales/implocal:TrasladosLocales")
For Each Nodo In ListaNodo
ISH = Nodo.Attributes.getNamedItem("Importe").Text
Next Nodo
'''''''''''''''''''''''''''AEROLINEAS''''''''''''''''''''''''''''''''''''''''''
Set ListaNodo = DocumentoXML.SelectNodes("cfdi:Comprobante/cfdi:Complemento/aerolineas:Aerolineas")
For Each Nodo In ListaNodo
TUA = Nodo.Attributes.getNamedItem("TUA").Text
Next Nodo

Set ListaNodo = DocumentoXML.SelectNodes("cfdi:Comprobante/cfdi:Complemento/aerolineas:Aerolineas/aerolineas:OtrosCargos/aerolineas:Cargo")
'MsgBox ListaNodo.Length
For Each Nodo In ListaNodo
YR = Nodo.Attributes.getNamedItem("Importe").Text
Next Nodo

''''''''''''''''''''''''''''''''''''UUID''''''''''''''''''''''''''''''''''''''''''''
Set ListaNodo = DocumentoXML.SelectNodes("/cfdi:Comprobante/cfdi:Complemento/tfd:TimbreFiscalDigital")
For Each Nodo In ListaNodo
UUID = Nodo.Attributes.getNamedItem("UUID").Text
Next Nodo

Cells(i, 1) = Fecha
Cells(i, 2) = Folio
Cells(i, 3) = RFC
Cells(i, 4) = Proveedor
Cells(i, 5) = Concepto
Cells(i, 5).ClearFormats
Cells(i, 6) = Subtotal - TUA - YR - Descuento
Cells(i, 7) = IVA
Cells(i, 8) = ISRRe
Cells(i, 9) = IVARe
Cells(i, 10) = IEPS
Cells(i, 11) = ISH
Cells(i, 12) = TUA
Cells(i, 13) = YR
Cells(i, 14) = Total
Cells(i, 15) = UUID

Fecha = ""
Folio = ""
RFC = ""
Proveedor = ""
Concepto = ""
Subtotal = 0
Descuento = 0
IVA = 0
ISRRe = 0
IVARe = 0
IEPS = 0
ISH = 0
TUA = 0
YR = 0
Total = 0
UUID = ""

Next
Cells(1, 1).Value = "Fecha"
Cells(1, 2).Value = "Folio"
Cells(1, 3).Value = "RFC"
Cells(1, 4).Value = "Proveedor"
Cells(1, 5).Value = "Concepto"
Cells(1, 6).Value = "Subtotal"
Cells(1, 7).Value = "IVA"
Cells(1, 8).Value = "ISR RETENIDO"
Cells(1, 9).Value = "IVA RETENIDO"
Cells(1, 10).Value = "IEPS"
Cells(1, 11).Value = "ISH"
Cells(1, 12).Value = "TUA"
Cells(1, 13).Value = "YR"
Cells(1, 14).Value = "Total"
Cells(1, 15).Value = "UUID"
      .Calculation = xlCalculationAutomatic
      .EnableEvents = True
      .DisplayStatusBar = True
    
   End With
End Sub

Descarga el archivo

Leer Más...