Comparar tablas excel (con access)

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