Es esta la solución más eficiente para quitar duplicados en access?

Option Compare Database

Option Explicit

' ===========================================================

' MÓDULO PERRÓN PARA CRUCE LLAMADAS ↔ CLASIFICACIONES

' - No crea tablas ni columnas; tú las defines una vez:

' * tblCruce_Final (campos de L + campos de C)

' * tblSinLlamada_Final (campos de C)

' * tblSinClasif_Final (campos de L)

' - Limpia salidas al arrancar; luego inserta resultados.

' - Lee nombres de campos automáticamente (DAO.TableDefs).

' - Regla: No debe haber nombres de campo iguales entre L y C.

' - Procesa por día calendario (DateValue), por rango o todo.

' ===========================================================

'========================

' Utilidades de esquema

'========================

' Devuelve los nombres de campos de una tabla como Collection.

Private Function GetFieldNames(ByVal tableName As String) As Collection

Dim c As New Collection, f As DAO.Field

For Each f In CurrentDb.TableDefs(tableName).Fields

    c.Add f.Name

Next f

Set GetFieldNames = c

End Function

' ¿Existe un nombre en la Collection (case-insensitive)?

Private Function InCollection(ByVal col As Collection, ByVal nameText As String) As Boolean

Dim v As Variant

For Each v In col

    If StrComp(CStr(v), nameText, vbTextCompare) = 0 Then

        InCollection = True

        Exit Function

    End If

Next v

InCollection = False

End Function

' Une columnas con comas, con o sin alias y con corchetes.

' - cols: Collection de nombres de columna

' - prefix: ej. "L." o "C." para armar SELECT L.[col]

' - bracket: True → usa [col]; False → sin corchete

Private Function JoinCols(ByVal cols As Collection, Optional ByVal prefix As String = "", Optional ByVal bracket As Boolean = True) As String

Dim parts() As String, i As Long, v As Variant, token As String

ReDim parts(0 To cols.Count - 1)

i = 0

For Each v In cols

    token = IIf(bracket, "[" & CStr(v) & "]", CStr(v))

    If Len(prefix) > 0 Then token = prefix & token

    parts(i) = token

    i = i + 1

Next v

JoinCols = Join(parts, ", ")

End Function

'========================

' Lectura de configuración

'========================

' Lee nombres de tablas/campos desde tblConfig.

' Requiere:

' - TablaLlamadas, CampoIdUsuario1, CampoInicio, CampoFin

' - TablaClasificador, CampoIdUsuario2, CampoFechaRegistro

Private Sub LeerConfig( _

ByRef tL As String, ByRef idL As String, ByRef iniL As String, ByRef finL As String, _

ByRef tC As String, ByRef idC As String, ByRef tsC As String)

Dim rs As DAO.Recordset

Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblConfig")

If rs.EOF Then Err.Raise vbObjectError + 9001, "LeerConfig", "tblConfig no tiene filas."

tL = Nz(rs!TablaLlamadas, "")

idL = Nz(rs!CampoIdUsuario1, "")

iniL = Nz(rs!CampoInicio, "")

finL = Nz(rs!CampoFin, "")

tC = Nz(rs!TablaClasificador, "")

idC = Nz(rs!CampoIdUsuario2, "")

tsC = Nz(rs!CampoFechaRegistro, "")

rs.Close

If tL = "" Or idL = "" Or iniL = "" Or finL = "" Or tC = "" Or idC = "" Or tsC = "" Then

    Err.Raise vbObjectError + 9002, "LeerConfig", "Faltan campos en tblConfig."

End If

End Sub

'========================

' Mapeo dinámico de columnas

'========================

' Arma el mapeo de columnas desde Origen → Destino:

' - Toma columnas de la tabla DESTINO

' - Conserva aquellas que también existan en la tabla ORIGEN

' Devuelve:

' destCols: columnas destino a insertar (orden destino)

' selCols : columnas origen a seleccionar (mismo orden)

Private Sub MapearDestino( _

ByVal tablaDestino As String, _

ByVal tablaOrigen As String, _

ByRef destCols As Collection, _

ByRef selCols As Collection)

Dim destAll As Collection, srcAll As Collection, v As Variant

Set destCols = New Collection

Set selCols = New Collection

Set destAll = GetFieldNames(tablaDestino)

Set srcAll = GetFieldNames(tablaOrigen)

For Each v In destAll

    If InCollection(srcAll, CStr(v)) Then

        destCols.Add CStr(v)  ' la columna existe en destino

        selCols.Add CStr(v)   ' y existe en origen (mismo nombre)

    End If

Next v

End Sub

'========================

' Limpieza idempotente

'========================

' Limpia TODAS las salidas al inicio de la corrida.

' (Como ya no usamos FechaProceso, esto evita duplicados)

Private Sub LimpiarTablasSalida()

CurrentDb.Execute "DELETE FROM tblCruce_Final"

CurrentDb.Execute "DELETE FROM tblSinLlamada_Final"

CurrentDb.Execute "DELETE FROM tblSinClasif_Final"

End Sub

'========================

' Días disponibles (por DateValue)

'========================

' Devuelve días calendario con datos en Clasificador, ordenados.

Private Function DiasDisponibles(ByVal tablaClasif As String, ByVal campoTS As String) As Collection

Dim c As New Collection, rs As DAO.Recordset

Dim sqlDias As String

sqlDias = "SELECT DISTINCT DateValue([" & campoTS & "]) AS Dia " & _

          "FROM [" & tablaClasif & "] ORDER BY Dia"

Set rs = CurrentDb.OpenRecordset(sqlDias)

Do While Not rs.EOF

    c.Add rs!Dia

    rs.MoveNext

Loop

rs.Close

Set DiasDisponibles = c

End Function

'========================

' Construcción de match dinámico

'========================

' Construye expresión multi-columna para NOT EXISTS:

' X.[col] = C.[col] AND X.[col2] = C.[col2] ...

' Se usa para comparar filas de C contra lo ya cruzado en tblCruce_Final.

' Si no hay columnas comunes (nunca debería pasar), retorna 1=0 (bloquea inserción).

Private Function JoinMatchExpr(ByVal cols As Collection, ByVal aliasX As String, ByVal aliasC As String) As String

Dim parts() As String, i As Long, v As Variant

If cols.Count = 0 Then

    JoinMatchExpr = "1=0"

    Exit Function

End If

ReDim parts(0 To cols.Count - 1)

i = 0

For Each v In cols

    parts(i) = "[" & aliasX & "].[" & CStr(v) & "] = [" & aliasC & "].[" & CStr(v) & "]"

    i = i + 1

Next v

JoinMatchExpr = Join(parts, " AND ")

End Function

'========================

' INSERTS (4 pasos)

'========================

' 1) Cruce en rango (FechaRegistro ∈ [Inicio, Fin]) para mismo ejecutivo

Private Function InsertCruceEnRango( _

ByVal tL As String, ByVal idL As String, ByVal iniL As String, ByVal finL As String, _

ByVal tC As String, ByVal idC As String, ByVal tsC As String, _

ByVal dia As Date, _

ByRef affected As Long) As Boolean

Dim destCols As New Collection, selL As New Collection, selC As New Collection

Dim destCols2 As New Collection, selCOnly As New Collection

Dim destColsStr As String, selStr As String, sqlText As String

Dim f As String: f = Format(dia, "yyyy-mm-dd")

' Mapear columnas que existen en tblCruce_Final desde L y luego desde C

Call MapearDestino("tblCruce_Final", tL, destCols, selL)

Call MapearDestino("tblCruce_Final", tC, destCols2, selCOnly)

' Unir: primero columnas de L, luego columnas de C (orden destino)

Dim v As Variant

For Each v In destCols2: destCols.Add v: Next v

For Each v In selCOnly: selC.Add v: Next v

destColsStr = JoinCols(destCols)                                ' [colA], [colB], ...

selStr = JoinCols(selL, "L.") & IIf(selL.Count > 0 And selC.Count > 0, ", ", "") & JoinCols(selC, "C.")

sqlText = "INSERT INTO tblCruce_Final (" & destColsStr & ") " & _

          "SELECT " & selStr & " " & _

          "FROM [" & tL & "] AS L INNER JOIN [" & tC & "] AS C " & _

          "ON L.[" & idL & "] = C.[" & idC & "] " & _

          "AND C.[" & tsC & "] BETWEEN L.[" & iniL & "] AND L.[" & finL & "] " & _

          "WHERE DateValue(C.[" & tsC & "]) = #" & f & "#"

CurrentDb.Execute sqlText

affected = CurrentDb.RecordsAffected

InsertCruceEnRango = True

End Function

' 2) Cruce por última previa (misma persona, MAX(Fin) < FechaRegistro)

Private Function InsertCruceUltimaPrevia( _

ByVal tL As String, ByVal idL As String, ByVal iniL As String, ByVal finL As String, _

ByVal tC As String, ByVal idC As String, ByVal tsC As String, _

ByVal dia As Date, _

ByRef affected As Long) As Boolean

Dim destCols As New Collection, selL As New Collection, selC As New Collection

Dim destCols2 As New Collection, selCOnly As New Collection

Dim destColsStr As String, selStr As String, sqlText As String

Dim f As String: f = Format(dia, "yyyy-mm-dd")

Call MapearDestino("tblCruce_Final", tL, destCols, selL)

Call MapearDestino("tblCruce_Final", tC, destCols2, selCOnly)

Dim v As Variant

For Each v In destCols2: destCols.Add v: Next v

For Each v In selCOnly: selC.Add v: Next v

destColsStr = JoinCols(destCols)

selStr = JoinCols(selL, "L.") & IIf(selL.Count > 0 And selC.Count > 0, ", ", "") & JoinCols(selC, "C.")

sqlText = "INSERT INTO tblCruce_Final (" & destColsStr & ") " & _

          "SELECT " & selStr & " " & _

          "FROM [" & tL & "] AS L INNER JOIN [" & tC & "] AS C " & _

          "ON L.[" & idL & "] = C.[" & idC & "] " & _

          "WHERE L.[" & finL & "] = (" & _

          "  SELECT MAX(L2.[" & finL & "]) FROM [" & tL & "] AS L2 " & _

          "  WHERE L2.[" & idL & "] = C.[" & idC & "] AND L2.[" & finL & "] < C.[" & tsC & "]" & _

          ") AND DateValue(C.[" & tsC & "]) = #" & f & "#"

CurrentDb.Execute sqlText

affected = CurrentDb.RecordsAffected

InsertCruceUltimaPrevia = True

End Function

' 3) Clasificaciones sin llamada (no presentes en tblCruce_Final ese día)

' Compara contra tblCruce_Final usando columnas comunes entre C y tblSinLlamada_Final.

Private Function InsertSinLlamada( _

ByVal tC As String, ByVal tsC As String, _

ByVal dia As Date, _

ByRef affected As Long) As Boolean

Dim destCols As New Collection, selC As New Collection

Dim destColsStr As String, selStr As String, sqlText As String

Dim f As String: f = Format(dia, "yyyy-mm-dd")

' Columnas de tblSinLlamada_Final que también existan en C

Call MapearDestino("tblSinLlamada_Final", tC, destCols, selC)

destColsStr = JoinCols(destCols)

selStr = JoinCols(selC, "C.")

sqlText = "INSERT INTO tblSinLlamada_Final (" & destColsStr & ") " & _

          "SELECT " & selStr & " FROM [" & tC & "] AS C " & _

          "WHERE DateValue(C.[" & tsC & "]) = #" & f & "# " & _

          "AND NOT EXISTS (" & _

          "  SELECT 1 FROM tblCruce_Final AS X " & _

          "  WHERE " & JoinMatchExpr(selC, "X", "C") & _

          ")"

CurrentDb.Execute sqlText

affected = CurrentDb.RecordsAffected

InsertSinLlamada = True

End Function

' 4) Llamadas sin clasificaciones (no presentes en tblCruce_Final ese día)

' Compara contra tblCruce_Final por Inicio, Fin, IdUsuario (lo mínimo para identidad de llamada).

Private Function InsertSinClasif( _

ByVal tL As String, ByVal idL As String, ByVal iniL As String, ByVal finL As String, _

ByVal dia As Date, _

ByRef affected As Long) As Boolean

Dim destCols As New Collection, selL As New Collection

Dim destColsStr As String, selStr As String, sqlText As String

Dim f As String: f = Format(dia, "yyyy-mm-dd")

' Columnas de tblSinClasif_Final que existan en L

Call MapearDestino("tblSinClasif_Final", tL, destCols, selL)

destColsStr = JoinCols(destCols)

selStr = JoinCols(selL, "L.")

sqlText = "INSERT INTO tblSinClasif_Final (" & destColsStr & ") " & _

          "SELECT " & selStr & " FROM [" & tL & "] AS L " & _

          "WHERE DateValue(L.[" & iniL & "]) = #" & f & "# " & _

          "AND NOT EXISTS (" & _

          "  SELECT 1 FROM tblCruce_Final AS X " & _

          "  WHERE X.[" & iniL & "] = L.[" & iniL & "] " & _

          "    AND X.[" & finL & "] = L.[" & finL & "] " & _

          "    AND X.[" & idL & "] = L.[" & idL & "]" & _

          ")"

CurrentDb.Execute sqlText

affected = CurrentDb.RecordsAffected

InsertSinClasif = True

End Function

'========================

' Orquestador (híbrido)

'========================

' Llamada principal:

' - Sin parámetros → procesa TODOS los días disponibles en el clasificador.

' - Con fechas (desde formulario) → procesa únicamente el rango.

' Requisitos:

' * tblCruce_Final contiene campos de L y de C (nombres distintos entre sí)

' * tblSinLlamada_Final contiene campos de C

' * tblSinClasif_Final contiene campos de L

Public Sub ProcesarRango(Optional ByVal fIni As Variant, Optional ByVal fFin As Variant)

On Error GoTo EH

Dim tL As String, idL As String, iniL As String, finL As String

Dim tC As String, idC As String, tsC As String

Dim dias As Collection, d As Variant

Dim minDia As Date, maxDia As Date

Dim totalCruce As Long, totalSinLlamada As Long, totalSinClasif As Long

Dim a As Long

' 1) Config

LeerConfig tL, idL, iniL, finL, tC, idC, tsC

' 2) Días disponibles en el insumo (clasificador)

Set dias = DiasDisponibles(tC, tsC)

If dias.Count = 0 Then

    MsgBox "No hay registros en la tabla de clasificador.", vbInformation

    Exit Sub

End If

' 3) Determinar rango efectivo

minDia = CDate(dias(1))

maxDia = CDate(dias(dias.Count))

If IsMissing(fIni) Or IsNull(fIni) Then fIni = minDia

If IsMissing(fFin) Or IsNull(fFin) Then fFin = maxDia

' 4) Limpiar salidas al inicio de la corrida

LimpiarTablasSalida

' 5) Procesar día por día dentro del rango

For Each d In dias

    If CDate(d) >= CDate(fIni) And CDate(d) <= CDate(fFin) Then

        ' (1) En rango

        InsertCruceEnRango tL, idL, iniL, finL, tC, idC, tsC, CDate(d), a

        totalCruce = totalCruce + a

        ' (2) Última previa

        InsertCruceUltimaPrevia tL, idL, iniL, finL, tC, idC, tsC, CDate(d), a

        totalCruce = totalCruce + a

        ' (3) Clasificaciones sin llamada

        InsertSinLlamada tC, tsC, CDate(d), a

        totalSinLlamada = totalSinLlamada + a

        ' (4) Llamadas sin clasificaciones

        InsertSinClasif tL, idL, iniL, finL, CDate(d), a

        totalSinClasif = totalSinClasif + a

    End If

Next d

' 6) Resumen final

MsgBox "Procesamiento completado: " & Format(CDate(fIni), "dd/mm/yyyy") & " a " & Format(CDate(fFin), "dd/mm/yyyy") & vbCrLf & vbCrLf & _

       "Registros insertados:" & vbCrLf & _

       "  tblCruce_Final: " & totalCruce & vbCrLf & _

       "  tblSinLlamada_Final: " & totalSinLlamada & vbCrLf & _

       "  tblSinClasif_Final: " & totalSinClasif, vbInformation

Exit Sub

EH:

MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "ProcesarRango"

End Sub

Option Compare Database

Option Explicit

' ====== VALORES POR DEFECTO ======

' Si llamas sin parámetros, se usarán estos nombres.

Public Const DEF_TABLA_ORIGEN As String = "TuTablaOrigen"

Public Const DEF_TABLA_DESTINO As String = "NORM_TuTablaOrigen"

Public Const DEF_TABLA_CONFIG_DEF As String = "tblNormalizacionDef"

Public Const DEF_TABLA_CONFIG_MAPEO As String = "tblMapeoCampos"

Public Const DEF_TABLA_CONFIG_TOKENS As String = "tblTokensIgnorados"

' Si TRUE, además de dejar en blanco todas las listas/comentarios configurados,

' se escribirá el token y comentario SOLO en el par activo de esa fila.

' Si FALSE, los campos originales de listas y comentarios siempre quedarán Null en la salida.

Public Const DEF_ESCRIBIR_TOKEN_EN_PAR_ACTIVO As Boolean = True

' ===============================================================

' UTILIDADES GENERALES

' ===============================================================

' Devuelve True si la tabla existe (ignora tablas del sistema)

Private Function ExisteTabla(ByVal nombreTabla As String) As Boolean

Dim t As DAO.TableDef

ExisteTabla = False

For Each t In CurrentDb.TableDefs

    If t.Attributes = 0 Or (t.Attributes And dbSystemObject) = 0 Then

        If t.Name = nombreTabla Then ExisteTabla = True: Exit Function

    End If

Next t

End Function

' Devuelve True si un campo existe dentro de una tabla

Private Function ExisteCampo(ByVal nombreTabla As String, ByVal nombreCampo As String) As Boolean

Dim t As DAO.TableDef

Dim f As DAO.Field

ExisteCampo = False

For Each t In CurrentDb.TableDefs

    If t.Name = nombreTabla Then

        For Each f In t.Fields

            If f.Name = nombreCampo Then ExisteCampo = True: Exit Function

        Next f

        Exit For

    End If

Next t

End Function

' Crea la tabla destino copiando TODOS los campos de la tabla origen

' y agrega 3 columnas auxiliares para trazabilidad.

Private Sub CrearTablaDestinoComoOrigenMasExtras(ByVal tablaOrigen As String, ByVal tablaDestino As String)

Dim db As DAO.Database

Dim tSrc As DAO.TableDef

Dim tNew As DAO.TableDef

Dim f As DAO.Field

Dim fNew As DAO.Field

Set db = CurrentDb

If ExisteTabla(tablaDestino) Then Exit Sub

Set tNew = db.CreateTableDef(tablaDestino)

For Each tSrc In db.TableDefs

    If tSrc.Name = tablaOrigen Then

        For Each f In tSrc.Fields

            If f.Type = dbText Or f.Type = dbBinary Then

                Set fNew = tNew.CreateField(f.Name, f.Type, f.Size)

            Else

                Set fNew = tNew.CreateField(f.Name, f.Type)

            End If

            tNew.Fields.Append fNew

        Next f

        Exit For

    End If

Next tSrc

tNew.Fields.Append tNew.CreateField("CampoDocumentoOrigen", dbText, 128)

tNew.Fields.Append tNew.CreateField("ValorDocumento", dbText, 255)

tNew.Fields.Append tNew.CreateField("ComentarioAsociado", dbMemo)

db.TableDefs.Append tNew

End Sub

' Convierte Null a cadena vacía

Private Function LimpiarNull(ByVal v As Variant) As String

If IsNull(v) Then LimpiarNull = "" Else LimpiarNull = CStr(v)

End Function

' Recorta espacios y comas residuales a izquierda/derecha

Private Function TrimToken(ByVal s As String) As String

Dim r As String

r = Trim$(s)

If Left$(r, 1) = "," Then r = Mid$(r, 2)

If Right$(r, 1) = "," Then r = Left$(r, Len(r) - 1)

TrimToken = Trim$(r)

End Function

' Lee definición general: destino, delimitador y si copiar sin expansión

Private Function LeerDef(ByVal tablaOrigen As String, ByVal tablaConfigDef As String, ByRef tablaDestino As String, ByRef delim As String, ByRef copiarSiSin As Boolean) As Boolean

Dim rs As DAO.Recordset

Dim sql As String

LeerDef = False

tablaDestino = "NORM_" & tablaOrigen

delim = ","

copiarSiSin = False

If Not ExisteTabla(tablaConfigDef) Then Exit Function

sql = "SELECT TOP 1 TablaDestino, Nz(Delimitador, ',') AS Delim, CopiarSiSinExpansion FROM [" & tablaConfigDef & "] WHERE TablaOrigen = '" & Replace(tablaOrigen, "'", "''") & "'"

Set rs = CurrentDb.OpenRecordset(sql, dbOpenSnapshot)

If Not rs.EOF Then

    tablaDestino = rs!TablaDestino

    delim = rs!Delim

    copiarSiSin = rs!CopiarSiSinExpansion

    LeerDef = True

End If

rs.Close

End Function

' Devuelve colección con ítems "CampoLista|CampoComentario" ordenados por Orden

Private Function LeerMapeos(ByVal tablaOrigen As String, ByVal tablaConfigMapeo As String) As Collection

Dim col As New Collection

Dim rs As DAO.Recordset

Dim sql As String

Dim item As String

If Not ExisteTabla(tablaConfigMapeo) Then Set LeerMapeos = col: Exit Function

sql = "SELECT CampoLista, CampoComentario FROM [" & tablaConfigMapeo & "] WHERE TablaOrigen = '" & Replace(tablaOrigen, "'", "''") & "' ORDER BY Orden"

Set rs = CurrentDb.OpenRecordset(sql, dbOpenSnapshot)

Do While Not rs.EOF

    item = LimpiarNull(rs!CampoLista) & "|" & LimpiarNull(rs!CampoComentario)

    col.Add item

    rs.MoveNext

Loop

rs.Close

Set LeerMapeos = col

End Function

' Carga tokens ignorados (en minúsculas y con trim)

Private Function CargarTokensIgnorados(ByVal tablaOrigen As String, ByVal tablaConfigTokens As String) As Collection

Dim col As New Collection

Dim rs As DAO.Recordset

Dim sql As String

If Not ExisteTabla(tablaConfigTokens) Then Set CargarTokensIgnorados = col: Exit Function

sql = "SELECT Token FROM [" & tablaConfigTokens & "] WHERE TablaOrigen = '" & Replace(tablaOrigen, "'", "''") & "'"

Set rs = CurrentDb.OpenRecordset(sql, dbOpenSnapshot)

Do While Not rs.EOF

    col.Add LCase$(Trim$(LimpiarNull(rs!Token)))

    rs.MoveNext

Loop

rs.Close

Set CargarTokensIgnorados = col

End Function

' Devuelve True si el token está vacío o en la lista de ignorados

Private Function TokenIgnorado(ByVal token As String, ByVal tokens As Collection) As Boolean

Dim t As Variant

Dim k As String

k = LCase$(Trim$(token))

If k = "" Then TokenIgnorado = True: Exit Function

On Error Resume Next

For Each t In tokens

    If k = t Then TokenIgnorado = True: Exit Function

Next t

End Function

' ===============================================================

' LIMPIEZA Y ASIGNACIÓN DE CAMPOS CONFIGURADOS EN LA FILA DESTINO

' ===============================================================

' Limpia TODOS los campos configurados (listas y comentarios) en la fila destino.

' Si asignarActivo=True, escribe el token y el comentario SOLO en el par activo.

Private Sub Normalizar_LimpiarYAsignarConfigurados(ByRef rsDst As DAO.Recordset, ByVal tablaOrigen As String, ByVal tablaConfigMapeo As String, ByVal nombreListaActivo As String, ByVal nombreComentarioActivo As String, ByVal tokenActivo As String, ByVal comentarioActivo As String, ByVal asignarActivo As Boolean)

Dim rs As DAO.Recordset

Dim sql As String

Dim nomLista As String

Dim nomComent As String

If ExisteTabla(tablaConfigMapeo) Then

    sql = "SELECT CampoLista, CampoComentario FROM [" & tablaConfigMapeo & "] WHERE TablaOrigen = '" & Replace(tablaOrigen, "'", "''") & "'"

    Set rs = CurrentDb.OpenRecordset(sql, dbOpenSnapshot)

    Do While Not rs.EOF

        nomLista = LimpiarNull(rs!CampoLista)

        nomComent = LimpiarNull(rs!CampoComentario)

        ' Limpia cada campo lista configurado (si existe en la tabla destino)

        If nomLista <> "" Then On Error Resume Next: rsDst.Fields(nomLista).Value = Null: On Error GoTo 0

        ' Limpia cada campo comentario configurado (si existe en la tabla destino)

        If nomComent <> "" Then On Error Resume Next: rsDst.Fields(nomComent).Value = Null: On Error GoTo 0

        rs.MoveNext

    Loop

    rs.Close

End If

' Escribe SOLO el par activo si así se desea

If asignarActivo Then

    If nombreListaActivo <> "" Then On Error Resume Next: rsDst.Fields(nombreListaActivo).Value = tokenActivo: On Error GoTo 0

    If nombreComentarioActivo <> "" Then On Error Resume Next: rsDst.Fields(nombreComentarioActivo).Value = comentarioActivo: On Error GoTo 0

End If

End Sub

' ===============================================================

' PROCEDIMIENTO PRINCIPAL

' ===============================================================

' Recorre la tabla origen y expande las listas definidas en tblMapeoCampos,

' insertando DIRECTO en la tabla destino una fila por token válido.

' Copia todos los campos NO configurados tal cual.

' Los campos configurados se limpian por fila, y opcionalmente se escribe el par activo.

Public Sub Normalizar_Expandir(Optional ByVal tablaOrigen As String = DEF_TABLA_ORIGEN, Optional ByVal tablaDestino As String = DEF_TABLA_DESTINO, Optional ByVal tablaConfigDef As String = DEF_TABLA_CONFIG_DEF, Optional ByVal tablaConfigMapeo As String = DEF_TABLA_CONFIG_MAPEO, Optional ByVal tablaConfigTokens As String = DEF_TABLA_CONFIG_TOKENS, Optional ByVal escribirTokenEnParActivo As Boolean = DEF_ESCRIBIR_TOKEN_EN_PAR_ACTIVO)

Dim db As DAO.Database

Dim rsSrc As DAO.Recordset

Dim rsDst As DAO.Recordset

Dim delim As String

Dim copiarSiSin As Boolean

Dim tieneDef As Boolean

Dim mapeos As Collection

Dim tokensIgn As Collection

Dim par As String

Dim nombreLista As String

Dim nombreComentario As String

Dim valorLista As String

Dim comentarioVal As String

Dim tokens() As String

Dim tok As Variant

Dim huboExp As Boolean

Dim f As DAO.Field

Dim i As Long

Set db = CurrentDb

' 1) Lee configuración general para la tabla origen

tieneDef = LeerDef(tablaOrigen, tablaConfigDef, tablaDestino, delim, copiarSiSin)

If Not tieneDef Then

    tablaDestino = IIf(Len(Trim$(tablaDestino)) = 0, "NORM_" & tablaOrigen, tablaDestino)

    delim = ","

    copiarSiSin = False

End If

' 2) Carga mapeos documento-comentario y tokens ignorados

Set mapeos = LeerMapeos(tablaOrigen, tablaConfigMapeo)

Set tokensIgn = CargarTokensIgnorados(tablaOrigen, tablaConfigTokens)

' 3) Crea tabla destino si no existe y la limpia para esta corrida

Call CrearTablaDestinoComoOrigenMasExtras(tablaOrigen, tablaDestino)

db.Execute "DELETE FROM [" & tablaDestino & "]", dbFailOnError

' 4) Abre origen y destino

Set rsSrc = db.OpenRecordset("SELECT * FROM [" & tablaOrigen & "]", dbOpenSnapshot)

Set rsDst = db.OpenRecordset("SELECT * FROM [" & tablaDestino & "]", dbOpenDynaset)

' 5) Itera cada registro de origen

Do While Not rsSrc.EOF

    huboExp = False

    ' Recorre cada par configurado

    For i = 1 To mapeos.Count

        par = mapeos(i)

        nombreLista = Split(par, "|")(0)

        nombreComentario = ""

        If UBound(Split(par, "|")) >= 1 Then nombreComentario = Split(par, "|")(1)

        ' Si el campo lista existe en la tabla y tiene datos

        If ExisteCampo(tablaOrigen, nombreLista) Then

            valorLista = LimpiarNull(rsSrc.Fields(nombreLista).Value)

            If valorLista <> "" Then

                tokens = Split(valorLista, delim)

                comentarioVal = ""

                If nombreComentario <> "" And ExisteCampo(tablaOrigen, nombreComentario) Then comentarioVal = LimpiarNull(rsSrc.Fields(nombreComentario).Value)

                ' Una fila por token válido

                For Each tok In tokens

                    tok = TrimToken(CStr(tok))

                    If Not TokenIgnorado(CStr(tok), tokensIgn) Then

                        rsDst.AddNew

                        ' Copia TODOS los campos del registro original

                        For Each f In rsSrc.Fields

                            rsDst.Fields(f.Name).Value = rsSrc.Fields(f.Name).Value

                        Next f

                        ' Limpia todas las listas/comentarios configurados y deja SOLO el par activo (si se desea)

                        Call Normalizar_LimpiarYAsignarConfigurados(rsDst, tablaOrigen, tablaConfigMapeo, nombreLista, nombreComentario, CStr(tok), comentarioVal, escribirTokenEnParActivo)

                        ' Escribe campos auxiliares de trazabilidad

                        rsDst.Fields("CampoDocumentoOrigen").Value = nombreLista

                        rsDst.Fields("ValorDocumento").Value = tok

                        rsDst.Fields("ComentarioAsociado").Value = comentarioVal

                        rsDst.Update

                        huboExp = True

                    End If

                Next tok

            End If

        End If

    Next i

    ' Si no se generó ninguna expansión y la config lo pide, copia el registro tal cual

    If Not huboExp And copiarSiSin Then

        rsDst.AddNew

        For Each f In rsSrc.Fields

            rsDst.Fields(f.Name).Value = rsSrc.Fields(f.Name).Value

        Next f

        rsDst.Fields("CampoDocumentoOrigen").Value = ""

        rsDst.Fields("ValorDocumento").Value = ""

        rsDst.Fields("ComentarioAsociado").Value = ""

        rsDst.Update

    End If

    rsSrc.MoveNext

Loop

' 6) Cierra recordsets

rsSrc.Close

rsDst.Close

MsgBox "Normalización completada. Tabla destino: " & tablaDestino, vbInformation

End Sub

Hola @Juan Antonio Figueroa
Esta respuesta ha sido traducida automáticamente. Como resultado, puede contener errores gramaticales o expresiones extrañas.

Gracias por su paciencia mientras investigaba esto.

Basándome en su código, creé una tabla de prueba y la ejecuté en mi entorno de Microsoft 365, y el resultado se muestra en la captura de pantalla a continuación.

Si este es el tipo de resultado que estaba buscando, puede consultar esta versión del código y ajustarla según sea necesario para su propio entorno.

Option Compare Database
Option Explicit
 
Public Sub GenerarUnicosTexto_Diccionario()
 
    Dim SOURCE_TABLE As String: SOURCE_TABLE = "TuTabla"
    Dim SOURCE_FIELD As String: SOURCE_FIELD = "identificadores"
    Dim OUTPUT_TABLE As String: OUTPUT_TABLE = "IdentificadoresUnicos"
    Dim OUTPUT_FIELD As String: OUTPUT_FIELD = "identificador"
 
    Dim NORMALIZAR_MAYUS As Boolean: NORMALIZAR_MAYUS = False
    Dim LIMPIAR_DOBLES_ESPACIOS As Boolean: LIMPIAR_DOBLES_ESPACIOS = False
    Dim VACIAR_TABLA_SALIDA As Boolean: VACIAR_TABLA_SALIDA = True
    Dim CREAR_INDICE_UNICO As Boolean: CREAR_INDICE_UNICO = True
 
    Dim db As DAO.Database: Set db = CurrentDb
    Call AsegurarTablaSalidaTexto(db, OUTPUT_TABLE, OUTPUT_FIELD)
 
    If VACIAR_TABLA_SALIDA Then
        db.Execute "DELETE FROM " & OUTPUT_TABLE, dbFailOnError
    End If
 
    Dim rs As DAO.Recordset
    Set rs = db.OpenRecordset( _
        "SELECT " & SOURCE_FIELD & " FROM " & SOURCE_TABLE & _
        " WHERE " & SOURCE_FIELD & " Is Not Null", dbOpenSnapshot)
 
    Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = vbTextCompare
 
    Dim s As String, arr() As String, i As Long, tok As String
    Dim totalTokens As Long: totalTokens = 0
 
    Do While Not rs.EOF
        s = Nz(rs.Fields(0).Value, "")
        If Len(s) > 0 Then
            arr = Split(s, ",")
            For i = LBound(arr) To UBound(arr)
                tok = Trim$(arr(i))
                If LIMPIAR_DOBLES_ESPACIOS Then tok = LimpiarEspaciosInternos(tok)
                If NORMALIZAR_MAYUS Then tok = UCase$(tok)
                If Len(tok) > 0 Then
                    If Not d.Exists(tok) Then d.Add tok, 1
                    totalTokens = totalTokens + 1
                End If
            Next i
        End If
        rs.MoveNext
    Loop
 
    rs.Close
    Set rs = Nothing
 
    If CREAR_INDICE_UNICO Then
        Call AsegurarIndiceUnico(db, OUTPUT_TABLE, OUTPUT_FIELD, "ux_" & OUTPUT_FIELD)
    End If
 
    Dim rsOut As DAO.Recordset
    Set rsOut = db.OpenRecordset(OUTPUT_TABLE, dbOpenDynaset)
 
    Dim k As Variant
    For Each k In d.Keys
        rsOut.AddNew
        rsOut.Fields(OUTPUT_FIELD).Value = CStr(k)
        rsOut.Update
    Next k
 
    rsOut.Close
    Set rsOut = Nothing
    Set db = Nothing
 
    MsgBox "Done. Tokens read: " & totalTokens & " | Unique: " & d.Count & " | Table: " & OUTPUT_TABLE, vbInformation, "Process complete"
 
End Sub
 
' --- Helper Subs and Functions ---
 
Private Sub AsegurarTablaSalidaTexto(db As DAO.Database, ByVal outTable As String, ByVal outField As String)
    If Not ExisteTabla(db, outTable) Then
        ' Create the table with the field if it does not exist
        db.Execute "CREATE TABLE " & outTable & " (" & outField & " TEXT(255))", dbFailOnError
    End If
End Sub
 
Private Sub AsegurarIndiceUnico(db As DAO.Database, ByVal tabla As String, ByVal campo As String, ByVal idx As String)
    If Not ExisteIndice(db, tabla, idx) Then
        db.Execute "CREATE UNIQUE INDEX " & idx & " ON " & tabla & " (" & campo & ")", dbFailOnError
    End If
End Sub
 
Private Function ExisteTabla(db As DAO.Database, ByVal nombre As String) As Boolean
    Dim t As DAO.TableDef
    For Each t In db.TableDefs
        If StrComp(t.Name, nombre, vbTextCompare) = 0 Then
            ExisteTabla = True
            Exit Function
        End If
    Next t
    ExisteTabla = False
End Function
 
Private Function ExisteCampo(db As DAO.Database, ByVal tabla As String, ByVal campo As String) As Boolean
    Dim t As DAO.TableDef, f As DAO.Field
    On Error Resume Next
    Set t = db.TableDefs(tabla)
    If Err.Number <> 0 Then
        ExisteCampo = False
        Err.Clear
        Exit Function
    End If
    On Error GoTo 0
    For Each f In t.Fields
        If StrComp(f.Name, campo, vbTextCompare) = 0 Then
            ExisteCampo = True
            Exit Function
        End If
    Next f
    ExisteCampo = False
End Function
 
Private Function ExisteIndice(db As DAO.Database, ByVal tabla As String, ByVal idx As String) As Boolean
    Dim t As DAO.TableDef, i As DAO.Index
    On Error Resume Next
    Set t = db.TableDefs(tabla)
    If Err.Number <> 0 Then
        ExisteIndice = False
        Err.Clear
        Exit Function
    End If
    On Error GoTo 0
    For Each i In t.Indexes
        If StrComp(i.Name, idx, vbTextCompare) = 0 Then
            ExisteIndice = True
            Exit Function
        End If
    Next i
    ExisteIndice = False
End Function
 
Private Function LimpiarEspaciosInternos(ByVal s As String) As String
    Dim r As String, c As String, prevSpace As Boolean, j As Long
    r = "": prevSpace = False
    For j = 1 To Len(s)
        c = Mid$(s, j, 1)
        If c = " " Then
            If Not prevSpace Then r = r & " "
            prevSpace = True
        Else
            r = r & c
            prevSpace = False
        End If
    Next j
    LimpiarEspaciosInternos = Trim$(r)
End Function

Espero que esto le sea útil.

Al parecer tiene que ver con begintrans pero aún así no correOption Compare Database

Option Explicit

Public Sub GenerarUnicosTexto_Diccionario_NoTrans()

Dim SOURCE_TABLE As String: SOURCE_TABLE = "TuTabla"

Dim SOURCE_FIELD As String: SOURCE_FIELD = "identificadores"

Dim OUTPUT_TABLE As String: OUTPUT_TABLE = "IdentificadoresUnicos"

Dim OUTPUT_FIELD As String: OUTPUT_FIELD = "identificador"

Dim NORMALIZAR_MAYUS As Boolean: NORMALIZAR_MAYUS = False

Dim LIMPIAR_DOBLES_ESPACIOS As Boolean: LIMPIAR_DOBLES_ESPACIOS = False

Dim VACIAR_TABLA_SALIDA As Boolean: VACIAR_TABLA_SALIDA = True

Dim CREAR_INDICE_UNICO As Boolean: CREAR_INDICE_UNICO = True

Dim db As DAO.Database: Set db = CurrentDb

Call AsegurarTablaSalidaTexto(db, OUTPUT_TABLE, OUTPUT_FIELD)

If VACIAR_TABLA_SALIDA Then db.Execute "DELETE FROM " & OUTPUT_TABLE, dbFailOnError

Dim rs As DAO.Recordset: Set rs = db.OpenRecordset("SELECT " & SOURCE_FIELD & " FROM " & SOURCE_TABLE & " WHERE " & SOURCE_FIELD & " Is Not Null", dbOpenSnapshot)

Dim d As Object: Set d = CreateObject("Scripting.Dictionary")

d.CompareMode = vbTextCompare

Dim s As String

Dim arr() As String

Dim i As Long

Dim tok As String

Dim totalTokens As Long: totalTokens = 0

Do While Not rs.EOF

    s = Nz(rs.Fields(0).Value, "")

    If Len(s) > 0 Then

        arr = Split(s, ",")

        For i = LBound(arr) To UBound(arr)

            tok = Trim$(arr(i))

            If LIMPIAR_DOBLES_ESPACIOS Then tok = LimpiarEspaciosInternos(tok)

            If NORMALIZAR_MAYUS Then tok = UCase$(tok)

            If Len(tok) > 0 Then

                If Not d.Exists(tok) Then d.Add tok, 1

                totalTokens = totalTokens + 1

            End If

        Next i

    End If

    rs.MoveNext

Loop

rs.Close

Set rs = Nothing

If CREAR_INDICE_UNICO Then Call AsegurarIndiceUnico(db, OUTPUT_TABLE, OUTPUT_FIELD, "ux_" & OUTPUT_FIELD)

Dim rsOut As DAO.Recordset: Set rsOut = db.OpenRecordset(OUTPUT_TABLE, dbOpenDynaset)

Dim k As Variant

For Each k In d.Keys

    rsOut.AddNew

    rsOut.Fields(OUTPUT_FIELD).Value = CStr(k)

    rsOut.Update

Next k

rsOut.Close

Set rsOut = Nothing

Set db = Nothing

MsgBox "Listo. Tokens leídos: " & totalTokens & " | Únicos: " & d.Count & " | Tabla: " & OUTPUT_TABLE, vbInformation, "Proceso completado"

End Sub

Private Sub AsegurarTablaSalidaTexto(db As DAO.Database, ByVal outTable As String, ByVal outField As String)

If Not ExisteTabla(db, outTable) Then db.Execute "CREATE TABLE " & outTable & " (" & outField & " TEXT(255))", dbFailOnError

If Not ExisteCampo(db, outTable, outField) Then db.Execute "ALTER TABLE " & outTable & " ADD COLUMN " & outField & " TEXT(255)", dbFailOnError

End Sub

Private Sub AsegurarIndiceUnico(db As DAO.Database, ByVal tabla As String, ByVal campo As String, ByVal idx As String)

If Not ExisteIndice(db, tabla, idx) Then db.Execute "CREATE UNIQUE INDEX " & idx & " ON " & tabla & " (" & campo & ")", dbFailOnError

End Sub

Private Function ExisteTabla(db As DAO.Database, ByVal nombre As String) As Boolean

Dim t As DAO.TableDef

For Each t In db.TableDefs

    If StrComp(t.Name, nombre, vbTextCompare) = 0 Then ExisteTabla = True: Exit Function

Next t

ExisteTabla = False

End Function

Private Function ExisteCampo(db As DAO.Database, ByVal tabla As String, ByVal campo As String) As Boolean

Dim t As DAO.TableDef: Dim f As DAO.Field

On Error Resume Next

Set t = db.TableDefs(tabla)

If Err.Number <> 0 Then ExisteCampo = False: Err.Clear: Exit Function

On Error GoTo 0

For Each f In t.Fields

    If StrComp(f.Name, campo, vbTextCompare) = 0 Then ExisteCampo = True: Exit Function

Next f

ExisteCampo = False

End Function

Private Function ExisteIndice(db As DAO.Database, ByVal tabla As String, ByVal idx As String) As Boolean

Dim t As DAO.TableDef: Dim i As DAO.Index

On Error Resume Next

Set t = db.TableDefs(tabla)

If Err.Number <> 0 Then ExisteIndice = False: Err.Clear: Exit Function

On Error GoTo 0

For Each i In t.Indexes

    If StrComp(i.Name, idx, vbTextCompare) = 0 Then ExisteIndice = True: Exit Function

Next i

ExisteIndice = False

End Function

Private Function LimpiarEspaciosInternos(ByVal s As String) As String

Dim r As String: Dim c As String: Dim prevSpace As Boolean: Dim j As Long

r = "": prevSpace = False

For j = 1 To Len(s)

    c = Mid$(s, j, 1)

    If c = " " Then

        If Not prevSpace Then r = r & " "

        prevSpace = True

    Else

        r = r & c

        prevSpace = False

    End If

Next j

LimpiarEspaciosInternos = Trim$(r)

End Function