VISHAL120
09-07-2015, 09:39 AM
Hi,
Am actually working on a project which is updating records on a MS Access database from Excel (VBA).
The project will be place on a network and will be available to around 20 users.
10 of these users will be Adding / Updating records to the database and the others will be ONLY updating the dates, comments, etc.
The Data normally are entered on the Worksheet and varies from 1 to several records at a time. Sometime 1 user can add only 1 record and others can add up to 10- 20 records at a time ( Like batch processing) depending on how many orders are being added.
Till now I have been testing same on my PC only as was still on the development and has not got problem of Adding or Updating.
But when i have tested it on the network i got Run time error like " Could not use " file already in use. I guess its the way the connection are being opened to exclusive. I am stuck with this since long and still searching solution for this, where several users can Add or Updates.
Am Attaching the Ms Access database and also below the codes being use to open ,ADD / Update.
Many thanks in advance for helping and guidance as i really need a helpful hand here to make this functional.
Codes to open connection as follows :
Public DBS As ADODB.Connection
Global RST As ADODB.Recordset
'Dim db As ADODB
Sub Connection_Open()
Set DBS = New ADODB.Connection
Set RST = New ADODB.Recordset
With DBS
.Provider = "Microsoft.ACE.OLEDB.12.0"
.CursorLocation = adUseClient
.ConnectionString = "C:\Karina_Int\Sample_Planning\Database\Sample_Process.accdb"
.Open
End With
End Sub
Sub Connection_Close()
If CBool(RST.State And adStateOpen) = True Then RST.Close
Set RST = Nothing
If CBool(DBS.State And adStateOpen) = True Then DBS.Close
Set DBS = Nothing
End Sub
Codes for add and update records:
Sub Upload_Marketing_Records_to_Database()
Application.ScreenUpdating = False ' Prevents screen refreshing.
Dim fld As ADODB.Field
Dim MyConn
Dim lngRow As Long
Dim lngId, LR, Upd
Dim j As Long
Dim ssql As String
Call set_filter_off
'clear actual data from file
LR = Range("A" & Rows.Count).End(xlUp).Row
Upd = LR - 1
Call Connection_Open
'set counter time
start_time = Time
lngRow = 11
Do While lngRow <= LR
Sheets("Marketing").Activate
lngId = Cells(lngRow, 1).Value
ssql = "SELECT * FROM Tbl_Sample_details WHERE Sample_Auto_ref = '" & lngId & "'"
Set RST = New ADODB.Recordset
RST.CursorLocation = adUseServer
RST.Open ssql, ActiveConnection:=DBS, _
CursorType:=adOpenKeyset, LockType:=adLockOptimistic
With RST
'If Not (.BOF And .EOF) = True Then
If .RecordCount = 0 Then
.AddNew
.Fields("Sample_Auto_ref") = Cells(lngRow, 1).Value
.Fields("Marketing_Manager") = Cells(lngRow, 2).Value
.Fields("Merchandiser") = Cells(lngRow, 3).Value
.Fields("Saison") = Cells(lngRow, 4).Value
.Fields("Client") = Cells(lngRow, 5).Value
.Fields("Ref_Client") = Cells(lngRow, 6).Value
.Fields("Ref_Karina") = Cells(lngRow, 7).Value
.Fields("Depart") = Cells(lngRow, 8).Value
.Fields("Theme") = Cells(lngRow, 9).Value
.Fields("Desc") = Cells(lngRow, 10).Value
.Fields("Type_Echantillion") = Cells(lngRow, 11).Value
.Fields("Taille") = Cells(lngRow, 12).Value
.Fields("Qty") = Cells(lngRow, 13).Value
.Fields("Keep_KI") = Cells(lngRow, 14).Value
.Fields("Type_Lavage") = Cells(lngRow, 15).Value
.Fields("Colori_Gmt_dyed") = Cells(lngRow, 16).Value
.Fields("Valeur_Ajouter") = Cells(lngRow, 17).Value
.Fields("Date_request_Merc") = Cells(lngRow, 18).Value
.Fields("Date_Livraison_Ech") = Cells(lngRow, 19).Value
.Fields("Date_Liv_Reviser") = Cells(lngRow, 20).Value
.Fields("Comm_Merc") = Cells(lngRow, 21).Value ' NOW FABRIC
.Fields("Comm_Client") = Cells(lngRow, 22).Value ' NOW ACCESSORIES
.Fields("PendIng_Rel") = Cells(lngRow, 23).Value
' .Fields("Date_Envoyer_Client") = Cells(lngRow, 24).Value
' .Fields("Courier_No") = Cells(lngRow, 25).Value
.Fields("Week_Number") = Cells(lngRow, 24).Value
.Fields("Month_Number") = Cells(lngRow, 25).Value
.Fields("Year_Control") = Cells(lngRow, 26).Value
.Fields("New_Order_Control") = Cells(lngRow, 27).Value
.Update
'MsgBox "record added new"
Else
.Fields("Sample_Auto_ref") = Cells(lngRow, 1).Value
.Fields("Marketing_Manager") = Cells(lngRow, 2).Value
.Fields("Merchandiser") = Cells(lngRow, 3).Value
.Fields("Saison") = Cells(lngRow, 4).Value
.Fields("Client") = Cells(lngRow, 5).Value
.Fields("Ref_Client") = Cells(lngRow, 6).Value
.Fields("Ref_Karina") = Cells(lngRow, 7).Value
.Fields("Depart") = Cells(lngRow, 8).Value
.Fields("Theme") = Cells(lngRow, 9).Value
.Fields("Desc") = Cells(lngRow, 10).Value
.Fields("Type_Echantillion") = Cells(lngRow, 11).Value
.Fields("Taille") = Cells(lngRow, 12).Value
.Fields("Qty") = Cells(lngRow, 13).Value
.Fields("Keep_KI") = Cells(lngRow, 14).Value
.Fields("Type_Lavage") = Cells(lngRow, 15).Value
.Fields("Colori_Gmt_dyed") = Cells(lngRow, 16).Value
.Fields("Valeur_Ajouter") = Cells(lngRow, 17).Value
.Fields("Date_request_Merc") = Cells(lngRow, 18).Value
.Fields("Date_Livraison_Ech") = Cells(lngRow, 19).Value
.Fields("Date_Liv_Reviser") = Cells(lngRow, 20).Value
.Fields("Comm_Merc") = Cells(lngRow, 21).Value ' NOW FABRIC
.Fields("Comm_Client") = Cells(lngRow, 22).Value ' NOW ACCESSORIES
.Fields("PendIng_Rel") = Cells(lngRow, 23).Value
' .Fields("Date_Envoyer_Client") = Cells(lngRow, 24).Value
' .Fields("Courier_No") = Cells(lngRow, 25).Value
.Fields("Week_Number") = Cells(lngRow, 24).Value
.Fields("Month_Number") = Cells(lngRow, 25).Value
.Fields("Year_Control") = Cells(lngRow, 26).Value
.Fields("New_Order_Control") = Cells(lngRow, 27).Value
RST.Update
'MsgBox "update me"
End If
End With
lngRow = lngRow + 1
Loop
'rst.Close 'the connection
Call Connection_Close
Range("A11:AC70").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Interior.ColorIndex = xlNone
'>>>making a calculation on the end time and start time
Call Set_Filter_on
End_Time = Time
Time_String = Format(End_Time - start_time, "ss")
'& Time_String & " secs"
'MsgBox "Data updated " & Upd & " records in " & Time_String & " secs"
Application.StatusBar = "Marketing Sample Data " & Upd & " Rows Updated in " & Time_String & " secs"
MsgBox "Records Save Successfully", vbInformation, "Sample Processing"
Application.ScreenUpdating = True
End Sub
Am actually working on a project which is updating records on a MS Access database from Excel (VBA).
The project will be place on a network and will be available to around 20 users.
10 of these users will be Adding / Updating records to the database and the others will be ONLY updating the dates, comments, etc.
The Data normally are entered on the Worksheet and varies from 1 to several records at a time. Sometime 1 user can add only 1 record and others can add up to 10- 20 records at a time ( Like batch processing) depending on how many orders are being added.
Till now I have been testing same on my PC only as was still on the development and has not got problem of Adding or Updating.
But when i have tested it on the network i got Run time error like " Could not use " file already in use. I guess its the way the connection are being opened to exclusive. I am stuck with this since long and still searching solution for this, where several users can Add or Updates.
Am Attaching the Ms Access database and also below the codes being use to open ,ADD / Update.
Many thanks in advance for helping and guidance as i really need a helpful hand here to make this functional.
Codes to open connection as follows :
Public DBS As ADODB.Connection
Global RST As ADODB.Recordset
'Dim db As ADODB
Sub Connection_Open()
Set DBS = New ADODB.Connection
Set RST = New ADODB.Recordset
With DBS
.Provider = "Microsoft.ACE.OLEDB.12.0"
.CursorLocation = adUseClient
.ConnectionString = "C:\Karina_Int\Sample_Planning\Database\Sample_Process.accdb"
.Open
End With
End Sub
Sub Connection_Close()
If CBool(RST.State And adStateOpen) = True Then RST.Close
Set RST = Nothing
If CBool(DBS.State And adStateOpen) = True Then DBS.Close
Set DBS = Nothing
End Sub
Codes for add and update records:
Sub Upload_Marketing_Records_to_Database()
Application.ScreenUpdating = False ' Prevents screen refreshing.
Dim fld As ADODB.Field
Dim MyConn
Dim lngRow As Long
Dim lngId, LR, Upd
Dim j As Long
Dim ssql As String
Call set_filter_off
'clear actual data from file
LR = Range("A" & Rows.Count).End(xlUp).Row
Upd = LR - 1
Call Connection_Open
'set counter time
start_time = Time
lngRow = 11
Do While lngRow <= LR
Sheets("Marketing").Activate
lngId = Cells(lngRow, 1).Value
ssql = "SELECT * FROM Tbl_Sample_details WHERE Sample_Auto_ref = '" & lngId & "'"
Set RST = New ADODB.Recordset
RST.CursorLocation = adUseServer
RST.Open ssql, ActiveConnection:=DBS, _
CursorType:=adOpenKeyset, LockType:=adLockOptimistic
With RST
'If Not (.BOF And .EOF) = True Then
If .RecordCount = 0 Then
.AddNew
.Fields("Sample_Auto_ref") = Cells(lngRow, 1).Value
.Fields("Marketing_Manager") = Cells(lngRow, 2).Value
.Fields("Merchandiser") = Cells(lngRow, 3).Value
.Fields("Saison") = Cells(lngRow, 4).Value
.Fields("Client") = Cells(lngRow, 5).Value
.Fields("Ref_Client") = Cells(lngRow, 6).Value
.Fields("Ref_Karina") = Cells(lngRow, 7).Value
.Fields("Depart") = Cells(lngRow, 8).Value
.Fields("Theme") = Cells(lngRow, 9).Value
.Fields("Desc") = Cells(lngRow, 10).Value
.Fields("Type_Echantillion") = Cells(lngRow, 11).Value
.Fields("Taille") = Cells(lngRow, 12).Value
.Fields("Qty") = Cells(lngRow, 13).Value
.Fields("Keep_KI") = Cells(lngRow, 14).Value
.Fields("Type_Lavage") = Cells(lngRow, 15).Value
.Fields("Colori_Gmt_dyed") = Cells(lngRow, 16).Value
.Fields("Valeur_Ajouter") = Cells(lngRow, 17).Value
.Fields("Date_request_Merc") = Cells(lngRow, 18).Value
.Fields("Date_Livraison_Ech") = Cells(lngRow, 19).Value
.Fields("Date_Liv_Reviser") = Cells(lngRow, 20).Value
.Fields("Comm_Merc") = Cells(lngRow, 21).Value ' NOW FABRIC
.Fields("Comm_Client") = Cells(lngRow, 22).Value ' NOW ACCESSORIES
.Fields("PendIng_Rel") = Cells(lngRow, 23).Value
' .Fields("Date_Envoyer_Client") = Cells(lngRow, 24).Value
' .Fields("Courier_No") = Cells(lngRow, 25).Value
.Fields("Week_Number") = Cells(lngRow, 24).Value
.Fields("Month_Number") = Cells(lngRow, 25).Value
.Fields("Year_Control") = Cells(lngRow, 26).Value
.Fields("New_Order_Control") = Cells(lngRow, 27).Value
.Update
'MsgBox "record added new"
Else
.Fields("Sample_Auto_ref") = Cells(lngRow, 1).Value
.Fields("Marketing_Manager") = Cells(lngRow, 2).Value
.Fields("Merchandiser") = Cells(lngRow, 3).Value
.Fields("Saison") = Cells(lngRow, 4).Value
.Fields("Client") = Cells(lngRow, 5).Value
.Fields("Ref_Client") = Cells(lngRow, 6).Value
.Fields("Ref_Karina") = Cells(lngRow, 7).Value
.Fields("Depart") = Cells(lngRow, 8).Value
.Fields("Theme") = Cells(lngRow, 9).Value
.Fields("Desc") = Cells(lngRow, 10).Value
.Fields("Type_Echantillion") = Cells(lngRow, 11).Value
.Fields("Taille") = Cells(lngRow, 12).Value
.Fields("Qty") = Cells(lngRow, 13).Value
.Fields("Keep_KI") = Cells(lngRow, 14).Value
.Fields("Type_Lavage") = Cells(lngRow, 15).Value
.Fields("Colori_Gmt_dyed") = Cells(lngRow, 16).Value
.Fields("Valeur_Ajouter") = Cells(lngRow, 17).Value
.Fields("Date_request_Merc") = Cells(lngRow, 18).Value
.Fields("Date_Livraison_Ech") = Cells(lngRow, 19).Value
.Fields("Date_Liv_Reviser") = Cells(lngRow, 20).Value
.Fields("Comm_Merc") = Cells(lngRow, 21).Value ' NOW FABRIC
.Fields("Comm_Client") = Cells(lngRow, 22).Value ' NOW ACCESSORIES
.Fields("PendIng_Rel") = Cells(lngRow, 23).Value
' .Fields("Date_Envoyer_Client") = Cells(lngRow, 24).Value
' .Fields("Courier_No") = Cells(lngRow, 25).Value
.Fields("Week_Number") = Cells(lngRow, 24).Value
.Fields("Month_Number") = Cells(lngRow, 25).Value
.Fields("Year_Control") = Cells(lngRow, 26).Value
.Fields("New_Order_Control") = Cells(lngRow, 27).Value
RST.Update
'MsgBox "update me"
End If
End With
lngRow = lngRow + 1
Loop
'rst.Close 'the connection
Call Connection_Close
Range("A11:AC70").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Interior.ColorIndex = xlNone
'>>>making a calculation on the end time and start time
Call Set_Filter_on
End_Time = Time
Time_String = Format(End_Time - start_time, "ss")
'& Time_String & " secs"
'MsgBox "Data updated " & Upd & " records in " & Time_String & " secs"
Application.StatusBar = "Marketing Sample Data " & Upd & " Rows Updated in " & Time_String & " secs"
MsgBox "Records Save Successfully", vbInformation, "Sample Processing"
Application.ScreenUpdating = True
End Sub