VBA – AODB Connection Update/Insert issue
Hi
I am new to this (never posted before!)
I have 3 workbooks each holding a list
I have another sheet that holds some info and a Save button
When the sheet is first saved (version 1) it copies itself to a location and inserts up to 4 new entries in each of the 3 (closed) workbook lists via the AODB connection – no problem with this, seems to work fine.
The problem comes when the data in the sheet is updated – again the sheet (now version2) copies correctly. Then I make an AODB connection to each of the other workbooks consecutively and update the (up to 4) entries pertaining to the previous version (changing a value from ‘L’ to “ “). I then insert up to 4 new rows with the latest data. – Unfortunately, The Insert after an Update doesn’t work if the workbook (being written to) is closed – it just doesn’t insert the new entry. (the update does work –changing the “L” to “ “. There are no error messages- all the data strings look correct- just doesn’t work. However, if the workbook being written to is open the Insert seems to work.
From when it has failed, on, the workbook being written to will not be ‘written to’ by the Insert statement until the workbook is opened and saved manually – then it will accept the Insert statement correctly (when open or closed) but will again not’ Insert’ after an ‘Update’.
I have tried many different approaches, including breaking the connections between Update and writing, changing connection Header yes/No etc. to no avail.
Any ideas – am I missing something fundamental about connections?
I have added code below:
Hi
I am new to this (never posted before!)
I have 3 workbooks each holding a list
I have another sheet that holds some info and a Save button
When the sheet is first saved (version 1) it copies itself to a location and inserts up to 4 new entries in each of the 3 (closed) workbook lists via the AODB connection – no problem with this, seems to work fine.
The problem comes when the data in the sheet is updated – again the sheet (now version2) copies correctly. Then I make an AODB connection to each of the other workbooks consecutively and update the (up to 4) entries pertaining to the previous version (changing a value from ‘L’ to “ “). I then insert up to 4 new rows with the latest data. – Unfortunately, The Insert after an Update doesn’t work if the workbook (being written to) is closed – it just doesn’t insert the new entry. (the update does work –changing the “L” to “ “. There are no error messages- all the data strings look correct- just doesn’t work. However, if the workbook being written to is open the Insert seems to work.
From when it has failed, on, the workbook being written to will not be ‘written to’ by the Insert statement until the workbook is opened and saved manually – then it will accept the Insert statement correctly (when open or closed) but will again not’ Insert’ after an ‘Update’.
I have tried many different approaches, including breaking the connections between Update and writing, changing connection Header yes/No etc. to no avail.
Any ideas – am I missing something fundamental about connections?
I have added code below:
Code:
Sub SheetUpdates(filename)
Dim ddate As Date
Dim SQLString As String
Dim conn As New ADODB.Connection
Dim conn1 As New ADODB.Connection
Dim DBPath As String
Dim sconnect As String
Dim sconnect1 As String
Dim ilast, ifound, r, d, e, C, iver, ilen, iser As Integer
Dim strsqlfields, statement, strno, strcode, strhub, strdate, strhub2 As String
Dim stryear, strInsp, strSgt, strOCU As String
With ThisWorkbook.Worksheets("Aid sheet")
strhub2 = .Range("N8").Text
strhub = "" 'Remove the spaces
ilen = Len(strhub2)
For C = 1 To ilen
If Mid(strhub2, C, 1) <> " " Then
strhub = strhub & Mid(strhub2, C, 1)
End If
Next C
'Read fields and construct a sql string to add record to the Hubsheet
'With ThisWorkbook.Worksheets("Aid sheet")
For r = 1 To 4
If r = 1 Then
sno = .Range("B81").Text 'SNo
strOCU = .Range("C47").Text
If sno = "" Then GoTo Endfor
ElseIf r = 2 Then
sno = .Range("B99").Text 'SNo
strOCU = .Range("C48").Text
If sno = "" Then GoTo Endfor
ElseIf r = 3 Then
sno = .Range("B114").Text 'SNo
strOCU = .Range("C49").Text
If sno = "" Then GoTo Endfor
ElseIf r = 4 Then
sno = .Range("B129").Text 'SNo
strOCU = .Range("C50").Text
If sno = "" Then GoTo Endfor
End If
strdate = .Range("E52").Text 'EventDate
For C = 1 To 30
If .Range("L" & 46 + r).Text = "Cancelled" Then
aser(r, 1) = "Cancelled"
Else
If C = 1 Then aser(r, 1) = ""
End If
If C = 2 Then aser(r, 2) = strOCU '
If C = 3 Then aser(r, 3) = strdate 'EventDate
If C = 4 Then aser(r, 4) = Month(Format(strdate, "dd/mm/yyyy"))
If C = 5 Then aser(r, 5) = .Range("E52").Text 'DateReceived '*************
If C = 6 Then aser(r, 6) = Month(Format(.Range("E52"), "dd/mm/yyyy"))
If C = 7 Then aser(r, 7) = "" 'Dept Planning
If C = 8 Then aser(r, 8) = .Range("E54").Text 'EventName
If C = 9 Then aser(r, 9) = Format(.Range("E62").Text, "hh:mm") 'Time
If C = 10 Then aser(r, 10) = .Range("B12").Text 'Event Type
If C = 11 Then aser(r, 11) = sno
If C = 12 Then aser(r, 12) = .Range("B4") 'Version
If C = 13 Then aser(r, 13) = .Range("B10").Text 'ServCode
If C = 14 Then aser(r, 14) = Val(.Range("F" & 46 + r).Text) '.Value 'I
If C = 15 Then aser(r, 15) = Val(.Range("G" & 46 + r).Text) '.Value 'S
If C = 16 Then aser(r, 16) = Val(.Range("H" & 46 + r).Text) '.Value 'P
If C = 17 Then aser(r, 17) = strUser
If C = 18 Then aser(r, 18) = Now
If C = 19 Then aser(r, 19) = Val(Left(.Range("I" & 46 + r), 1)) 'Iplus
If C = 20 Then aser(r, 20) = Val(Mid(.Range("I" & 46 + r), 3, 1)) 'Splus
If C = 21 Then aser(r, 21) = Val(Right(.Range("I" & 46 + r), 1)) 'Pplus
If C = 22 Then aser(r, 22) = Val(Left(.Range("J" & 46 + r), 1)) 'Iminus
If C = 23 Then aser(r, 23) = Val(Mid(.Range("J" & 46 + r), 3, 1)) 'Sminus
If C = 24 Then aser(r, 24) = Val(Right(.Range("J" & 46 + r), 1)) 'Pminus
If C = 25 Then aser(r, 25) = Val(Left(.Range("K" & 46 + r), 1)) 'Ishort
If C = 26 Then aser(r, 26) = Val(Mid(.Range("K" & 46 + r), 3, 1)) 'Sshort
If C = 27 Then aser(r, 27) = Val(Right(.Range("K" & 46 + r), 1)) 'Pshort
If C = 28 And sno <> "" Then aser(r, 28) = "L" 'Live record
If C = 29 Then aser(r, 29) = strUser '"" 'Supervised By
If C = 30 Then aser(r, 30) = Now '"" 'Supervised Date
Next C
Endfor:
Next r
'Write it to check it
With ThisWorkbook.Worksheets("Sheet1")
.Range("A2:AT5").ClearContents
.Range("A2:AT5") = aser
End With
strdate = Format(.Range("E52").Text, "dd/mm/yyyy") 'EventDate
stryear = Year(Format(.Range("E52").Text, "dd/mm/yyyy"))
'******************* Write to HubWorksheet ************************
DBPath = strFilePath & strhub & "\" & strhub & " Work.xlsx" ''
'Check if file available
If Len(Dir(DBPath)) = 0 Then MsgBox "Hub sheet workfile not found!" & Chr(10) & Chr(10) & "Contact SC&O22 I.T Solutions.", vbCritical: Exit Sub
If Val(.Range("B4")) > 1 Then '*** 'An Update for HubWorkBook **************************
retry:
'On Error Resume Next
' Open a connection - 2013
Set conn = New ADODB.Connection
sconnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DBPath _
& ";Extended Properties = ""Excel 12.0 Xml;HDR=No"""
conn.Open sconnect
If conn.State <> 1 Then
MsgBox "Waiting for the Hub WorkSheet file..... Click OK to continue"
GoTo retry
End If
For d = 1 To 4
If d = 1 Then
sno = .Range("B81").Text 'SNo
strOCU = .Range("C47").Text
ElseIf d = 2 Then
sno = .Range("B99").Text 'SNo
strOCU = .Range("C48").Text
ElseIf d = 3 Then
sno = .Range("B114").Text 'SNo
strOCU = .Range("C49").Text
ElseIf d = 4 Then
sno = .Range("B129").Text 'SNo
strOCU = .Range("C50").Text
End If
If sno <> "" Then conn.Execute ("UPDATE [Data$] SET f28 = ' ' WHERE f11= '" & sno & "'And f3= '" & strdate & "'")
Next d
conn.Close
Set conn = Nothing
End If
'******Now Insert additional records in Hub WorkSheet file
'Make new connection
retry1:
'On Error Resume Next
' Open a connection - 2013
Set conn1 = New ADODB.Connection
sconnect1 = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DBPath _
& ";Extended Properties = ""Excel 12.0 Xml;HDR=No"""
conn1.Open sconnect1
If conn1.State <> 1 Then
MsgBox "Waiting for the Hub WorkSheet file..... Click OK to continue"
GoTo retry1
End If
For e = 1 To 4
If .Range("E" & 46 + e) <> "" Then
strsqlfields = ""
For C = 1 To 30
If C = 1 Then
strsqlfields = "'',"
ElseIf C = 9 Then
strsqlfields = strsqlfields & "'" & aser(e, C) & "'," 'Time
ElseIf C = 14 Or C = 15 Or C = 16 Then
strsqlfields = strsqlfields & aser(e, C) & "," 'Count of I,P&Cs
ElseIf C = 30 Then
strsqlfields = strsqlfields & "'" & aser(e, C) & "'" 'Last one
Else
strsqlfields = strsqlfields & "'" & aser(e, C) & "'," 'All others-text
End If
'End If
'End If
Next C
'Then add a new Record with the latest version - with an "L" in column AB to denote the live version
statement = "INSERT INTO [Data$] " & "VALUES (" & strsqlfields & ")"
Call conn1.Execute(statement, , CommandTypeEnum.adCmdText)
End If
'Endfor2:
Next e
conn1.Close
Set conn1 = Nothing
End With
Call AddSerials(filename)
'Call AddOthers
End Sub
[/Code)
