Links to named ranges don't update in database

I'm trying to relink existing excel tables to new excel workbooks.

I successfully create new named ranges in the workbooks, and the aclink
command seems to work, but when I examine the excel links, they are still
linked to the old data. Here's my code:

Sub NewXLData()
Dim strXLDir As String
Dim rsTblNames As DAO.Recordset
Dim strSQL As String
Dim WkBk As Excel.Workbook
Dim WkSht As Excel.Worksheet
Dim rng As Excel.Range
Dim NmdRng As Excel.Name
Dim wkshtName As String
Dim rngName As String
Dim rngAddress As String
Dim fName As String
Dim dtWkBk As Date
Dim iTblID As Long
Dim lclName As String
Dim strConnect As String
Dim WkbkName As String

strSQL = "SELECT TBLID, WkbkName, lclName, CellTxt, RngNm, dtLastUpld" &
vbCrLf
strSQL = strSQL & "FROM tblXLNames" & vbCrLf
strSQL = strSQL & "ORDER BY SortOrd"

Set rsTblNames = dbLocal.OpenRecordset(strSQL)

If rsTblNames.EOF Or rsTblNames.BOF Then Exit Sub

strXLDir = Me.txtPath

If ExcelIsRunning Then
    Set xlObj = GetObject(, "Excel.Application")
Else
    Set xlObj = CreateObject("Excel.Application")
End If

With xlObj
    .Visible = False
    .ReferenceStyle = xlR1C1
End With

With rsTblNames
    .MoveFirst
    Do Until .EOF
        WkbkName = Dir(strXLDir & .Fields("WkbkName"))
        If Len(WkbkName) = 0 Then GoTo NextWkbk
        fName = strXLDir & WkbkName
        Set WkBk = xlObj.Workbooks.Open(fName)
        dtWkBk = WkBk.BuiltinDo***entProperties("Creation Date")
'        dtWkBk = FileDateTime(fName)
        iTblID = .Fields("TBLID")
        lclName = .Fields("lclName")
        rngName = .Fields("RngNm")
'        If .Fields("dtLastUpld") < dtWkBk Then
        If .Fields("dtLastUpld") <> dtWkBk Then
            Set WkSht = WkBk.ActiveSheet
            wkshtName = WkSht.Name
            xlObj.Cells.Find(.Fields("CellTxt")).Activate
            xlObj.ReferenceStyle = xlR1C1
            rngAddress = xlObj.ActiveCell.CurrentRegion.Address
(ReferenceStyle:=xlR1C1)
            WkBk.Names.Add Name:=rngName, RefersToR1C1:="='" & wkshtName &
"'!
" & rngAddress
            WkBk.Close True
            Set WkBk = Nothing
            
            DropTable lclName
    
            DoCmd.TransferSpreadsheet acLink, acSpreadsheetTypeExcel9,
lclName, fName, True, rngName
            
            strSQL = "UPDATE tblXLNames SET dtLastUpld = #" & dtWkBk
            strSQL = strSQL & "#, dtLastDwnld = #" & Now
            strSQL = strSQL & "# WHERE TBLID=" & iTblID
            
            dbLocal.Execute (strSQL)
            SetIMEX2 1, lclName
        Else
            WkBk.Close True
            Set WkBk = Nothing
        End If
NextWkbk:
        If Not .EOF Then .MoveNext
    Loop
    .Close
End With

Set rsTblNames = Nothing
Set WkSht = Nothing
Set WkBk = Nothing
Set xlObj = Nothing

EnableFtrCtrls

End Sub

Any help would be appreciated.

-- 
Bill Reed

"If you can't laugh at yourself, laugh at somebody else"

Message posted via AccessMonster.com
http://www.accessmonster.com/Uwe/Forums.aspx/access-externaldata/200808/1