Comparar Tablas Excel con Access

Comparar tablas excel (con access)

En las tareas de evaluación de programas de mantenimiento, es frecuente la de comparar dos tablas excel. Vamos a verlo, basándonos en la herramienta desarrollada en Access, con toda la información explicada en el post:

Lo que vamos a hacer es importar las tablas Excel a Access (con la primera fila de las mismas conteniendo el nombre de los campos o columnas). Vamos a seleccionar el campo de referencia sobre el cual vamos a comparar las tablas (campo referencia) y aquellos campos que queremos comparar.

Usar Access tiene como ventaja que las consultas son muy rápidas y pueden realizarse muy fácilmente con el lenguaje SQL. Eso es lo que vamos a hacer, efectuando las siguientes consultas:

  • Consulta de duplicados en ambas tablas (por si existe algún campo referencia duplicado),
  • Consulta de no coincidentes entre ambas tablas, para ver los valores de campo referencia que se han eliminado en la la segunda tabla con respecto a la primera, y aquellos que están en la segunda tabla pero no en la primera.
  • Consulta de diferencias: Para aquellos valores de campo referencia comunes en ambas tablas, se trata de ver las diferencias en una selección de campos de la tabla (la aplicación contempla 7, pero es fácilmente escalable).

Para la comparación, nos basaremos en el algoritmo de similitud de cadenas de texto (ya comentado en el post al que hacía referencia al principio). De esta manera, podemos ver si los valores son aproximadamente iguales o no (teniendo en cuenta que se introduce una penalización en el caso de números distintos)

Requisitos previos en Access y a tener en cuenta

Las referencias a usar son las de expresiones regulares y Excel

Referencias de la aplicación Access

A tener en cuenta e importante es el hecho de que al importar las tablas Excel en Acces, los valores vacíos en ellas se traducen en registros Nulos en Access. Eso hace que las fórmulas matemáticas del algoritmo de similitud fallen (y aunque en Access se indica con #Error), y por tanto falle también la copia del resultado al Excel final. Por eso, antes de empezar, se modifican todos los valores nulos, en aquellos campos que se comparan por la cadena de texto vacía «», eso sí, previamente convertimos el campo a tipo «texto», (los tipo memo se truncarán) (una primera estrategia fue cambiar el valor nulo por «-99999», pero mostraba resultados que no tenían que estar). Para ello, la referencia está en el código del siguiente enlace:

https://stackoverflow.com/questions/29064325/replacing-null-values-for-multiple-columns-in-a-table-with-a-constant-value

Funcionamiento

El primer paso es importar las tablas Excel en Access.

Después seleccionamos ambas tablas, el campo común y aquellos campos que queremos comparar (cuantos más se seleccionen, más tardará en sacar los resultados)

El botón actualizar la lista de tablas recarga las mismas y sus campos

Podemos indicar que se añadan el resto de los campos de la tablas y si se quieren limpiar los mismos en la comparación (limpiar lo que hace es eliminar espacios dobles, saltos de línea y espacios al final, lo que evita falsos positivos)

Formulario de la aplicación en Access

Una vez pulsado el botón Go!, se abre Excel en segundo plano y se van creando pestañas donde se van insertando los resultados de las consultas con el método CopyFromRecordset.

Por último, en la pestaña correspondiente a las diferencias, se marcan en color amarillo los valores cambiados. Las columnas «Expr1«, «Expr2«, «Expr3«… muestran el valor del algoritmo de similitud para cada par de campos previos a ellos (los que hemos ido señalando). El valor ‘1’ siginifica 100% similituo o igualdad.

La columna «ExprTotal» muestra la suma de todos los valores de la Expr, por tanto si tenemos 4 campos comparados, un valor ‘4’ significa que no ha cambiado inguno de ellos y podremos filtrarlos fácilmente en el Excel.

Ejemplo, ordenando de menor a mayor por ExprTotal

Los resultados del resto de pestañas:

Duplicados en la primera tabla
Duplicados en la segunda tabla
Referencias de la primera tabla que faltan en la segunda tabla
referencias nuevas en la segunda tabla con respecto a la primera

Video DEMO

Demo con dos tablas de unos 1000 filas cada una
ESCALABILIDAD

Aunque el formulario incluye 7 campos, es fácilmente escalable, introduciendo campos para cada tabla, pero dándoles un nombre (propiedad Name del ComboBox) del tipo campo1_XX y campo2_XX, y modificando el código (primeras líneas) donde se definen unas constantes que se separarán en un array (nombres de los campos separados por comas, sin espacios)

Option Compare Database
Const camposCombo1 = «campo1_1,campo1_2,campo1_3,campo1_4,campo1_5,campo1_6,campo1_7» ' para usar en arrays en el código y permitir escalabilidad
Const camposCombo2 = «campo2_1,campo2_2,campo2_3,campo2_4,campo2_5,campo2_6,campo2_7» ' para usar en arrays en el código

Descarga y código de la aplicación (Access) para comparar tablas excel

El archivo Access (creado en Access 2016) es el siguiente:

Descargar: Comparar_Tablas.zip

Código VBA:

El formulario ha de tener los desplegables o combos con los nombres:

comboTabla1, comboTabla2, comboCampo1 y comboCampo2, para las tablas y los campos comunes para las búsquedas (y el resto como se ha explicado antes en el apartado escalabilidad). El nombre de los botones y checkbox es fácilmente deducible del código.

Option Compare Database
Const camposCombo1 = "campo1_1,campo1_2,campo1_3,campo1_4,campo1_5,campo1_6,campo1_7" ' para usar en arrays en el código y permitir escalabilidad
Const camposCombo2 = "campo2_1,campo2_2,campo2_3,campo2_4,campo2_5,campo2_6,campo2_7" ' para usar en arrays en el código


Private Sub actualizarTablas_Click()
Call Form_Load
End Sub

Private Sub comandoEjecutar_Click()

Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSh As Excel.Worksheet
Dim row As Integer
Dim col As Integer
Dim count As Integer

Dim db As DAO.Database
Dim rst1 As DAO.Recordset
Dim rst2 As DAO.Recordset

Dim seleccion As String
Dim total As String
Dim campo1 As String
Dim campo2 As String

Dim campos1(20) As String
Dim campos2(20) As String

Dim valor As Variant
Dim i As Integer
Dim j As Integer

Dim strquery As String

On Error GoTo ERROR
'inicializar
DoCmd.Hourglass True

' comprobar que el campo a comprobar está seleccionado en ambas tablas
If comboCampo1 = "" Or comboCampo2 = "" Then
        MsgBox ("Alguno de los campos comunes no se ha seleccionado")
        Exit Sub
End If

' limpiar las tablas para que no haya nulos
quitarNulos (comboTablas1)
quitarNulos (comboTablas2)

For i = 0 To UBound(campos1) - LBound(campos1) - 1
    campos1(i) = ""
    campos2(i) = ""
Next
count = 1
row = 1
col = 1

Set db = CurrentDb()

'------------------------------------------
' Búsqueda de duplicados en ambas tablas
'------------------------------------------

' Para las primeras consultas
campo1 = "[" & comboTablas1 & "].[" & comboCampo1 & "]"
campo2 = "[" & comboTablas2 & "].[" & comboCampo2 & "]"

strquery = "SELECT " & campo1 & ",* FROM [" & comboTablas1 & "] " _
    & "WHERE (((" & campo1 & ") In (SELECT [" & comboCampo1 & "] " _
    & "FROM [" & comboTablas1 & "] As Tmp GROUP BY [" & comboCampo1 & "] HAVING Count(*)>1 ))) " _
    & "ORDER BY " & campo1 & ";"
'abrir consulta
Set rst1 = db.OpenRecordset(strquery)

strquery = "SELECT " & campo2 & ",* FROM [" & comboTablas2 & "] " _
    & "WHERE (((" & campo2 & ") In (SELECT [" & comboCampo2 & "] " _
    & "FROM [" & comboTablas2 & "] As Tmp GROUP BY [" & comboCampo2 & "] HAVING Count(*)>1 ))) " _
    & "ORDER BY " & campo2 & ";"
'abrir consulta
Set rst2 = db.OpenRecordset(strquery)


' abrir excel de resultados
Set xlApp = New Excel.Application
Set xlWB = xlApp.Workbooks.Add ' crea un nuevo libro
Set xlSh = xlWB.Sheets(1) '

'xlApp.Visible = True
xlApp.Visible = False
textLog.SetFocus
Beep
textLog.SetFocus
textLog.Text = "Buscando duplicados..."
DoEvents

' Duplicados tabla 1

xlWB.Sheets(1).Name = Left("Duplicados " & comboTablas1, 30) ' error en tabs con monbres más largos

Call rellenarExcelRst(xlSh, rst1)
'Call rellenarExcel(xlSh, rst1, row, comboCampo1, comboTablas1)

' Duplicados tabla 2
xlWB.Sheets.Add After:=xlWB.Sheets(1)
Set xlSh = xlWB.Sheets(2) '
xlWB.Sheets(2).Name = Left("Duplicados " & comboTablas2, 30)

'Call rellenarExcel(xlSh, rst2, row, comboCampo2, comboTablas2)
Call rellenarExcelRst(xlSh, rst2)

rst1.Close
rst2.Close

'------------------------------------------
' NO COINCIDENTES
'------------------------------------------
textLog.SetFocus
textLog.Text = "Buscando No Coincidentes..."
DoEvents

strquery = "SELECT * FROM [" & comboTablas1 & "] LEFT JOIN [" & comboTablas2 & "] ON " _
        & campo1 & " = " & campo2 & " WHERE (((" & campo2 & ") Is Null));"


'abrir consulta
Set rst1 = db.OpenRecordset(strquery)

strquery = "SELECT * FROM [" & comboTablas2 & "] LEFT JOIN [" & comboTablas1 & "] ON " _
        & campo2 & " = " & campo1 & " WHERE (((" & campo1 & ") Is Null));"

' abrir consulta
Set rst2 = db.OpenRecordset(strquery)

' Tabla1 no en Tabla2
xlWB.Sheets.Add After:=xlWB.Sheets(2)

Set xlSh = xlWB.Sheets(3) '
xlWB.Sheets(3).Name = Left(comboTablas1 & " FALTAN EN " & comboTablas2, 30)

'row = 1
'Call rellenarExcel(xlSh, rst1, row, comboCampo1, comboTablas1)
Call rellenarExcelRst(xlSh, rst1)

' inmovilizar fila superior
With xlApp.ActiveWindow
            .SplitColumn = 0
            .SplitRow = 1
            .FreezePanes = True
End With
    
' Tabla 2 no en Tabla1
xlWB.Sheets.Add After:=xlWB.Sheets(3)

Set xlSh = xlWB.Sheets(4) '
xlWB.Sheets(4).Name = Left(comboTablas2 & " FALTAN EN " & comboTablas1, 30)

'row = 1
'Call rellenarExcel(xlSh, rst2, row, comboCampo2, comboTablas2)
Call rellenarExcelRst(xlSh, rst2)

' inmovilizar fila superior
With xlApp.ActiveWindow
            .SplitColumn = 0
            .SplitRow = 1
            .FreezePanes = True
End With
rst1.Close
rst2.Close

'------------------------------------------
' Diffs Tabla 1 vs Tabla2
'------------------------------------------
textLog.SetFocus
textLog.Text = "Buscando Diferencias en los campos..."
DoEvents
' rellenar array campos1
i = 0
For Each valor In Split(camposCombo1, ",")
        If Not IsNull(Me.Controls(valor)) Then
            campos1(i) = Me.Controls(valor)
        Else
            campos1(i) = ""
        End If
        i = i + 1
Next
' rellenar array campos2
i = 0
For Each valor In Split(camposCombo2, ",")
        If Not IsNull(Me.Controls(valor)) Then
            campos2(i) = Me.Controls(valor)
        Else
            campos2(i) = ""
        End If
        i = i + 1
Next

' chequeos de campos y creación consulta
seleccion = ""
total = ""

i = 0

Do While campos1(i) <> ""
    If campos2(i) = "" Then
        MsgBox ("Campo Tabla 2 vacío")
        Exit Sub
    Else
        campo1 = "[" & comboTablas1 & "].[" & campos1(i) & "]"
        campo2 = "[" & comboTablas2 & "].[" & campos2(i) & "]"
        If checkBoxLimpiar.Value = True Then
            seleccion = seleccion & "," & campo1 & "," & campo2 & ", Similitud_adpt(limpiar(" & campo1 & "),limpiar(" & campo2 & ")) AS Expr" & i + 1
        Else
            seleccion = seleccion & "," & campo1 & "," & campo2 & ", Similitud_adpt(" & campo1 & "," & campo2 & ") AS Expr" & i + 1
        End If
        If i = 0 Then
            total = ", [Expr" & i + 1 & "]"
        Else
            total = total & "+[Expr" & i + 1 & "]"
        End If
    End If
    
    i = i + 1
Loop

' añadimos la expresión con el valor total de las similitudes
If total <> "" Then total = total & " AS ExprTotal"

' resto de campòs de las tablas
If CheckboxTabla1.Value = True Then
    total = total & ", [" & comboTablas1 & "].*"
End If

If CheckboxTabla2.Value = True Then
    total = total & ", [" & comboTablas2 & "].*"
End If

campo1 = "[" & comboTablas1 & "].[" & comboCampo1 & "]"
campo2 = "[" & comboTablas2 & "].[" & comboCampo2 & "]"

' seleccion y total ya llevan la primera ","
strquery = "SELECT " & campo1 & seleccion & total & " FROM [" & comboTablas1 & "] INNER JOIN " _
            & "[" & comboTablas2 & "] ON " & campo1 & " = " & campo2 & ";"
' No limpio los campos de la inner join, pues tarda demasiado, hacer esto previamente
'If checkBoxLimpiar.Value = True Then
'    strquery = "SELECT " & campo1 & seleccion & total & " FROM [" & comboTablas1 & "] INNER JOIN " _
'            & "[" & comboTablas2 & "] ON limpiar(" & campo1 & ") = limpiar(" & campo2 & ");"
'End If
' abrir consulta
Set rst1 = db.OpenRecordset(strquery)



' Diffs Tabla1 vs Tabla2
xlWB.Sheets.Add After:=xlWB.Sheets(4)

Set xlSh = xlWB.Sheets(5) '
xlWB.Sheets(5).Name = Left("DIFFS " & comboTablas1 & " vs " & comboTablas2, 30)

row = 1
xlApp.Calculation = xlManual
'Call rellenarExcel(xlSh, rst1, row, comboCampo1, comboTablas1)
Call rellenarExcelRst(xlSh, rst1)
xlApp.Calculation = xlAutomatic
' inmovilizar fila superior
With xlApp.ActiveWindow
            .SplitColumn = 0
            .SplitRow = 1
            .FreezePanes = True
End With

Beep
textLog.Text = "Coloreando tabla Excel..."
DoEvents

Call pintarExcel(xlSh, rst1)

rst1.Close
db.Close
Set rst1 = Nothing
Set rst2 = Nothing
Set db = Nothing

Beep
textLog.SetFocus
textLog.Text = ""
DoEvents
DoCmd.Hourglass False

MsgBox ("FIN")

xlApp.Visible = True
Exit Sub
ERROR:
    MsgBox ("Ha ocurrido un error" & vbCrLf & vbCrLf & Err.Description & vbCrLf & vbCrLf & "Se recargará el formulario")
    DoCmd.Hourglass False
    xlWB.Close
    Call Form_Load
    Exit Sub
End Sub
Private Sub rellenarExcelRst(xlSh As Excel.Worksheet, rst As DAO.Recordset)
Dim iCols As Integer
For iCols = 0 To rst.Fields.count - 1
 xlSh.Cells(1, iCols + 1).Value = rst.Fields(iCols).Name
 xlSh.Cells(1, iCols + 1).Interior.ColorIndex = 15
Next
' si el rst está vacío salimos, pues da errores
If rst.EOF Then
    xlSh.Cells(2, 1) = "NO SE HAN ENCONTRADO"
    Exit Sub
End If
rst.MoveLast
rst.MoveFirst

xlSh.Range("A2").CopyFromRecordset rst

'For iCols = 1 To rst.RecordCount
'    xlSh.Rows(iCols).RowHeight = xlSh.Rows(1).RowHeight
'Next
' igualamos ancho de todas las filas y ponemos autofiltro
'xlSh.Range("A2:A" & xlSh.Rows.count).RowHeight = xlSh.Rows(1).RowHeight
xlSh.Range("A1").AutoFilter
xlSh.Cells.Select
xlSh.Cells.EntireColumn.AutoFit
xlSh.Cells.EntireRow.AutoFit

End Sub
Private Sub pintarExcel(xlSh As Excel.Worksheet, rst As DAO.Recordset)
Dim iCols As Integer ' xls empieza en 1
Dim iRows As Integer ' xls empieza en 1
For iCols = 0 To rst.Fields.count - 1
    If Left(rst.Fields(iCols).Name, 4) = "Expr" And rst.Fields(iCols).Name <> "ExprTotal" Then ' estamos en una columna con valores de comparación
        For iRows = 1 To rst.RecordCount
            ' la primera fila son los campos
            If xlSh.Cells(iRows + 1, iCols + 1).Value < 1 Then
                xlSh.Cells(iRows + 1, iCols).Interior.ColorIndex = 6 ' o 27 , amarillos
                xlSh.Cells(iRows + 1, iCols - 1).Interior.ColorIndex = 6 ' o 27 , amarillos
            End If
            If iRows Mod 50 = 0 Then
                textLog.SetFocus
                textLog.Text = "Columna:" & iCols & " Fila: " & iRows & "/" & rst.RecordCount
                DoEvents
            End If
        Next
    End If
    If rst.Fields(iCols).Name = "ExprTotal" Then xlSh.Cells(1, iCols + 1).Interior.ColorIndex = 42 'azul
Next

End Sub
Private Sub rellenarExcel(xlSh As Excel.Worksheet, rst As DAO.Recordset, row As Integer, comboCampo As String, comboTabla As String)
Dim col As Integer
Dim count As Integer
Dim i As Integer
Dim valor As Variant


If Not (rst.EOF And rst.BOF) Then
    rst.MoveLast
    rst.MoveFirst
    count = rst.RecordCount
    i = 1
    For Each valor In rst.Fields
        xlSh.Cells(row, i) = valor.Name
        ' paleta de colores https://www.excel-easy.com/vba/examples/background-colors.html
        xlSh.Cells(row, i).Interior.ColorIndex = 15 'gris
        i = i + 1
    Next
    row = row + 1
      
    Do Until rst.EOF
        i = 1
        For Each valor In rst.Fields
            If Not IsNull(valor.Value) Then
                xlSh.Cells(row, i) = valor.Value
            Else
                xlSh.Cells(row, i) = ""
            End If
            i = i + 1
        Next
        xlSh.Rows(row).RowHeight = xlSh.Rows(1).RowHeight
        If row Mod 50 = 0 Then
            textLog.Text = " Diifs, Fila: " & row & "/" & count
            DoEvents
        End If
    row = row + 1
    rst.MoveNext
    Loop
End If

End Sub

Private Sub comboTablas1_Click()
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim comboName As Variant
If IsNull(comboTablas1) Or comboTablas1 = "" Then Exit Sub


'Limpiar combobox campos
While comboCampo1.ListCount > 0
    comboCampo1.RemoveItem 0
    For Each comboName In Split(camposCombo1, ",")
        Me.Controls(comboName).RemoveItem 0
    Next
Wend

comboCampo1 = ""
For Each comboName In Split(camposCombo1, ",")
        Me.Controls(comboName) = ""
Next
    
Set db = CurrentDb()
Set rst = db.OpenRecordset(comboTablas1)
Dim fld As DAO.Field
For Each fld In rst.Fields
    comboCampo1.AddItem (fld.Name)
    For Each comboName In Split(camposCombo1, ",")
        Me.Controls(comboName).AddItem (fld.Name)
    Next
Next
rst.Close
Set fld = Nothing
Set rst = Nothing
Set db = Nothing


End Sub

Private Sub comboTablas2_Click()
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim comboName As Variant

If IsNull(comboTablas2) Or comboTablas2 = "" Then Exit Sub


'Limpiar combobox
While comboCampo2.ListCount > 0
    comboCampo2.RemoveItem 0
    For Each comboName In Split(camposCombo2, ",")
        Me.Controls(comboName).RemoveItem 0
    Next
Wend

comboCampo2 = ""
For Each comboName In Split(camposCombo2, ",")
        Me.Controls(comboName) = ""
Next

Set db = CurrentDb()
Set rst = db.OpenRecordset(comboTablas2)
Dim fld As DAO.Field
For Each fld In rst.Fields
    comboCampo2.AddItem (fld.Name)
    For Each comboName In Split(camposCombo2, ",")
        Me.Controls(comboName).AddItem (fld.Name)
    Next
Next
rst.Close
Set fld = Nothing
Set rst = Nothing
Set db = Nothing


End Sub

Private Sub Form_Load()
Dim comboName As Variant
Set db = CurrentDb()
comboTablas1.RowSource = ""
comboCampo1.RowSource = ""
comboTablas2.RowSource = ""
comboCampo2.RowSource = ""

For Each comboName In Split(camposCombo1, ",")
        Me.Controls(comboName).RowSource = ""
Next
For Each comboName In Split(camposCombo2, ",")
        Me.Controls(comboName).RowSource = ""
Next

For Each td In db.TableDefs
    If Left(td.Name, 4) <> "MSys" And td.Name <> "RegExp" Then
        comboTablas1.AddItem (td.Name)
        comboTablas2.AddItem (td.Name)
    End If
Next td

CheckboxTabla1.Value = False
CheckboxTabla2.Value = False
checkBoxLimpiar.Value = False

Set td = Nothing
Set db = Nothing

End Sub

Private Sub quitarNulos(tablaName As String)
'https://stackoverflow.com/questions/29064325/replacing-null-values-for-multiple-columns-in-a-table-with-a-constant-value
Dim db As DAO.Database
Dim fld As DAO.Field
Dim tdf As DAO.TableDef

Dim strUpdate As String

Dim campoBusqueda As String
Dim camposBusqueda(20) As String
Dim i As Integer

Set db = CurrentDb
Set tdf = db.TableDefs(tablaName)

' Array con los campos de búsqueda, para comprobar si estamos en uno de ellos, en las tablas a comparar

' para la tabla1
i = 0
If tablaName = comboTablas1.Value Then
    i = 0
    For Each valor In Split(camposCombo1, ",")
        If Not IsNull(Me.Controls(valor)) Then
            camposBusqueda(i) = Me.Controls(valor)
        Else
            camposBusqueda(i) = ""
        End If
        i = i + 1
    Next
End If
' para la tabla 2
i = 0
If tablaName = comboTablas2.Value Then
    For Each valor In Split(camposCombo2, ",")
        If Not IsNull(Me.Controls(valor)) Then
            camposBusqueda(i) = Me.Controls(valor)
        Else
            camposBusqueda(i) = ""
        End If
        i = i + 1
    Next
End If


For Each fld In tdf.Fields
    ' Access will complain if you attempt an UPDATE on an autonumber field,
    ' so skip field with dbAutoIncrField attribute
    If Not ((fld.Attributes And dbAutoIncrField) = dbAutoIncrField) Then
        ' ver además si es un campo de búsqueda
        i = 0
        Do While camposBusqueda(i) <> ""
            If fld.Name = camposBusqueda(i) Then
                ' convertir a tipo texto
                If fld.Type <> dbText Then ' cazamos los números y los memo
                    MsgBox "Se va a cambiar el tipo de datos de " & fld.Name & " de la tabla " & tablaName & " a TEXTO", vbExclamation
                    db.Execute "ALTER TABLE [" & tablaName & "] ALTER COLUMN [" & fld.Name & "] TEXT;"
                End If
                ' cambiar si es nulo y poner cadena vacía
                    strUpdate = "UPDATE [" & tablaName & "] SET [" & fld.Name & _
                        "] = """" WHERE [" & fld.Name & "] Is Null;"
                    '   "] = -99999 WHERE [" & fld.Name & "] Is Null;"
                    'Debug.Print strUpdate
                    db.Execute strUpdate, dbFailOnError
            End If
        i = i + 1
        Loop
        
    End If
    
Next

End Sub



Leave a Reply

Tu dirección de correo electrónico no será publicada.

Este sitio usa Akismet para reducir el spam. Aprende cómo se procesan los datos de tus comentarios.