Excel - Bloqueo/Desbloquedo Access de VBA

Estimados, soy nuevo en este foro y espero me puedan ayudar.

Desarrollo una aplicacion en Excel con base de datos Access 2000, y aumento el nuero de usuarios que acceden a ella a 25, cuando son muchos los que intentan grabar registros, la aplicacion excel en vba me enterga el mensaje "-2147467259, No se pudo actualizar; actualmente este elemento está bloqueado." y no me deja insertar nuevos registros.

El acceso a la base de dato se realiza con ADO con la referencia "Microsoft ActiveX Data Objects 2.7 Library".

A continuacion insertare el codigo de apertura de la base de datos.

NomBase = "bdIntegrador PMMG III.mdb"
Set OBD = Nothing
Set OBD = New adodb.Connection
PathBase = "D:\SistemaIntegradores\"
StringConeccion = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & PathBase & NomBase & ";Persist Security Info=False" & ";Jet OLEDB:Database Password=" & "SLAbanco"
OBD.Open StringConeccion

La forma como inserto nuevos registros es generando una string con los instrucciones SQL y luego la ejectuto con la instruccion Execute como lo indica en ejemplo.

ejemplo:

OBD.Execute SQL

Como puede manuelamente contralar el bloqueo y desbloqueo de las iniciativas?

de ante mano muchas gracias.


El siguiente codigo es de un insert a la base de datos.

SQL = "insert into Iniciativas ("
SQL = SQL & "IdIntegrador,"
SQL = SQL & "IdCiclo, "
SQL = SQL & "NombreProyectoIniciativa,"
SQL = SQL & "NumeroADR, "
SQL = SQL & "FlujoStock, "
SQL = SQL & "Descripcion, "
SQL = SQL & "IdAgrupacion, "
SQL = SQL & "NombreGantt, "
SQL = SQL & "FechaIngresoIniciativa, "
SQL = SQL & "FechaIngresoHoy, "
SQL = SQL & "GanttIdGS, "
SQL = SQL & "ConSinGantt, "
SQL = SQL & "IdEtapa, "
SQL = SQL & "IdEjecutivoResponsable, "
SQL = SQL & "GerenciaAreaDivision, "
SQL = SQL & "AreaEjecResponsable, "
SQL = SQL & "IdSolicitante, "
SQL = SQL & "IdProducto, "
SQL = SQL & "IdSegmento, "
SQL = SQL & "LoginCreador, "
SQL = SQL & "Equipo, "
SQL = SQL & "IdTipoSLA, "
SQL = SQL & "IdAreaInterna, "
SQL = SQL & "IdAmbito, "
SQL = SQL & "IdResponsableID, "
SQL = SQL & "IdCanal, "
SQL = SQL & "IdClasificaIniciativa, "
SQL = SQL & "IdOrigenNecesidad, "
SQL = SQL & "IdClienteActivo"
If IdIntegrador = 4 Then
SQL = SQL & ", IdProyectoPadre"
SQL = SQL & ", IsRequerimientoMenor, "
SQL = SQL & "IsEstrategico, "
SQL = SQL & "IdNormativo, "
SQL = SQL & "IdResponsableIni"
ElseIf IdIntegrador = 2 Then
SQL = SQL & ", IdProyectoPadre"
SQL = SQL & ", IdResponsableIni"
SQL = SQL & ", IdEspecialistaCom"
ElseIf IdIntegrador = 3 Then
SQL = SQL & ", IdProyectoPadre"
SQL = SQL & ", IdtipoEntrega"
Else
SQL = SQL & ", IdProyectoPadre"
End If

SQL = SQL & ") values ("
SQL = SQL & IdIntegrador & ", "
SQL = SQL & "1,'"
SQL = SQL & Me.TBNombreADR.Text & "', "
SQL = SQL & CStr(NumAdr) & ", "
SQL = SQL & "'Flujo', '"
SQL = SQL & Me.TBDescripcionIniciativa.Text & "', "
SQL = SQL & IdAgrupacion & ", "
SQL = SQL & "'Flujo', '"
SQL = SQL & FecIngreso & "', '"
SQL = SQL & FechaTexto(LFechaInicio.Caption) & "', '"
SQL = SQL & GanttIdGS & "', "
SQL = SQL & "'Sin Gantt', "
SQL = SQL & IdEstado & ", "
SQL = SQL & IdEjecutivo & ", '"
SQL = SQL & GerAreDiv & "', '"
SQL = SQL & AreEjeRes & "', "
SQL = SQL & IdSolicitante & ", "
SQL = SQL & IdProducto & ", "
SQL = SQL & IdSegmento & ", "
SQL = SQL & "'" & NombreUsuario & "',"
SQL = SQL & "'" & NombreEquipo & "', "
SQL = SQL & IdTipoSLA & ", "
SQL = SQL & IdAreaInterna & ", "
SQL = SQL & IdAmbito & ", "
SQL = SQL & IdResponsableID & ", "
SQL = SQL & IdCanal & ", "
SQL = SQL & IdClasifica & ", "
SQL = SQL & IdOrigen & ", "
SQL = SQL & IdClienteActivo & ", "
If IdIntegrador = 4 Then
SQL = SQL & IdProyectoPadre & ","
If Me.CheckBoxRequerimientoMenor.Value = True Then
SQL = SQL & 1 & ", "
Else
SQL = SQL & 0 & ", "
End If
If Me.CheckBoxRelacionProyectoEstrategico.Value = True Then
SQL = SQL & 1 & ", "
Else
SQL = SQL & 0 & ", "
End If
SQL = SQL & IdNormativo & ", "
SQL = SQL & IdResponsableIni & ")"
ElseIf IdIntegrador = 2 Then
SQL = SQL & IdProyectoPadre & ","
SQL = SQL & IdResponsableIni & ","
SQL = SQL & IdEspecialistaIni & ")"
ElseIf IdIntegrador = 3 Then
SQL = SQL & IdProyectoPadre & ", "
SQL = SQL & IdTipoEntrega & ")"
Else
SQL = SQL & IdProyectoPadre & ")"
End If
TipoAcceso = 2 ' Insertar
OBD.Execute SQL
' Busca El IdIniciativa con el numero adr
Dim BusIdIni As New adodb.Recordset
Set BusIdIni = New adodb.Recordset
SQL = "select IdIniciativa from Iniciativas where numeroadr = " & NumAdr
BusIdIni.Open SQL, OBD, adOpenDynamic, adLockBatchOptimistic
If Not BusIdIni.EOF Then
IdIniciativa = ValidaNum(BusIdIni!IdIniciativa)
Else
IdIniciativa = 0
End If
' Graba la Detalle Etapa

SQL = "Insert into DetalleCambioEstado ("
SQL = SQL & "IdIniciativa, "
SQL = SQL & "AreaResponsable, "
SQL = SQL & "NumeroADR, "
SQL = SQL & "NombreIniciativaADR, "
SQL = SQL & "AreaEjeResponsable, "
SQL = SQL & "IdEjecutivoResponsable, "
SQL = SQL & "NombreEjecResponsable, "
SQL = SQL & "IdSolicitante, "
SQL = SQL & "NombreSolicitante, "
SQL = SQL & "FechaIngresoADR, "
SQL = SQL & "Proceso, "
SQL = SQL & "Etapa, "
SQL = SQL & "FechaInicioProceso, "
SQL = SQL & "FechaInicioEtapa, "
SQL = SQL & "ResponsableEtapaEnPyT, "
SQL = SQL & "FechaRecepcionSolicitudPyT, "
SQL = SQL & "FechaCompromiso, "
SQL = SQL & "ObservacionOtroImportante, "
SQL = SQL & "OrdenEtapa, "
SQL = SQL & "IdEstado, "
SQL = SQL & "FechaCreacion, "
SQL = SQL & "HoraCreacion, "
SQL = SQL & "LoginCreador, "
SQL = SQL & "Equipo "
SQL = SQL & ") values ("

SQL = SQL & IdIniciativa & ", "
SQL = SQL & "'" & AreRes & "', "
SQL = SQL & CStr(NumAdr) & ", "
SQL = SQL & "'" & TBNombreADR.Text & "', "
SQL = SQL & "'" & AreEjeRes & "', "
SQL = SQL & IdEjecutivo & ", "
SQL = SQL & "'" & Me.ComboBoxEjecutivo.Text & "', "
SQL = SQL & IdSolicitante & ", "
SQL = SQL & "'" & Me.ComboBoxSolicitante.Text & "', "
SQL = SQL & "'" & FecIngreso & "', "
SQL = SQL & "'" & Me.LProceso.Caption & "', "
SQL = SQL & "'" & Me.ComboBoxEstado.Text & "', "
SQL = SQL & "'" & FecCambioEstado & "', "
SQL = SQL & "'" & FecCambioEstado & "', "
SQL = SQL & "'" & Me.ComboBoxResponsablePyT.Text & "', "
SQL = SQL & "'" & FecCambioEstado & "', "
SQL = SQL & "'" & FecCompromiso & "', "
SQL = SQL & "'" & Me.TBObservaciones.Text & "', "
SQL = SQL & Orden & ", "
SQL = SQL & "1, "
SQL = SQL & "'" & FechaTexto(Format(Date, "dd-mm-yyyy")) & "', "
SQL = SQL & "'" & Format(Time, "hh:mm") & "',"
SQL = SQL & "'" & NombreUsuario & "', "
SQL = SQL & "'" & NombreEquipo & "')"
OBD.Execute SQL