Versión mejorada en: https://abrazalaweb.net/2021/04/comparar-tablas-excel-version-mejorada/
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

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

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.

Los resultados del resto de pestañas:




Video DEMO
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:
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
[…] Comparar tablas excel (con access) – Abraza la Web […]