R
ragtopcaddy via AccessMonster.com
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.BuiltinDocumentProperties("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.
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.BuiltinDocumentProperties("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.