Posts by Arkwright2

    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 different approaches, breaking the connections between Update and writing, to no avail.


    Any ideas – am I missing something fundamental about connections?



    [VBA]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 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[/VBA]