Access - Copiar Mdb por Código

Private Sub btnCopiar_Click()

    Dim db As DAO.Database

    Dim tdf As DAO.TableDef

    Dim rel As DAO.Relation

    Dim rs As DAO.Recordset

    Dim filtro As String

    Dim nuevaBaseDatos As String

    ' Especifica el valor del campo para el filtro

    filtro = Me.txtFiltro.Value

    ' Especifica el nombre de la nueva base de datos

    nuevaBaseDatos = "ruta_de_la_nueva_base_de_datos.mdb" ' Cambiar por la ruta y nombre deseado

    ' Crea una nueva base de datos en la ubicación especificada

    Set db = CreateDatabase(nuevaBaseDatos, dbLangGeneral)

    ' Copia la estructura de las tablas y relaciones de la base de datos actual a la nueva base de datos

    For Each tdf In CurrentDb.TableDefs

        If Left(tdf.Name, 4) <> "MSys" Then ' Evita copiar tablas del sistema

            db.TableDefs.Append tdf

        End If

    Next tdf

    ' Copia los datos filtrados de las tablas a la nueva base de datos

    For Each tdf In db.TableDefs

        If Left(tdf.Name, 4) <> "MSys" Then

            Set rs = CurrentDb.OpenRecordset("SELECT * FROM [" & tdf.Name & "] WHERE [NombreCampoFiltro] = '" & filtro & "'")

            Do Until rs.EOF

                tdf.OpenRecordset.AddNew

                For Each fld In tdf.Fields

                    fld.Value = rs(fld.Name).Value

                Next fld

                tdf.OpenRecordset.Update

                rs.MoveNext

            Loop

            rs.Close

        End If

    Next tdf

    ' Cierra y libera recursos

    db.Close

    Set db = Nothing

    MsgBox "Copia completada con éxito.", vbInformation

End Sub