Ok, self answering.
- This subroutine checks if the linked table already exists and then updates the table if it does.
- The data on the Excel spreadsheet can move around. So long as the target header column always exists then this macro will find the first row that contains the header.
- It utilizes excel's "Used Range" functionality, which isn't always 100% accurate, but it seems to be working well in my situation.
If adapting this code:
- Be sure to modify the target table names and the target header text in this code to match your Excel file.
- Be sure that the target header text isn't duplicated in the excel file and that it is on the same row as the other headers.
- The row of the target header text is used as the starting row for the target range
- Be sure that your target worksheet is the first worksheet in the workbook.
Thanks to this tek-tips post for the basis of this code. I am no expert, but this accomplishes what I set out to do. I'm sure this code could be streamlined further.
Public Sub ImportCLINDataSub()
Dim strCurrProjPath As String
Dim objExcel As Object 'Excel.Application
Dim objWorkbook As Object 'Excel.Workbook
Dim objWorksheet As Object 'Worksheet
Dim strXlFileName As String 'Excel Workbook name
Dim strWorksheetName As String 'Excel Worksheet name
Dim objCell As Object 'Last used cell in column
Dim strTargetRow As String 'Cell containing target text
Dim strUsedRange As String 'Used range
Dim strUsedRange1 As String 'This will store the first half of the used range, adjusted for the appropriate row
Dim strUsedRange1Column As String 'This will store the column value of the first half of the used range
Dim strUsedRange2 As String 'This will store the second half of the used range
Dim FileName As String
Dim objDialog, boolResult
Dim iPosition As Integer 'For finding first numeric character
Set objDialog = CreateObject("UserAccounts.CommonDialog")
objDialog.Filter = "Excel Files|*.xlsx|All Files|*.*"
objDialog.FilterIndex = 1
boolResult = objDialog.ShowOpen
If boolResult = 0 Then
Exit Sub
Else
'Assign Path and filename of XL file to variable
strXlFileName = objDialog.FileName
'Assign Excel application to a variable
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False 'Can be visible or not visible
objExcel.UserControl = True
'Open the Excel Workbook
Set objWorkbook = objExcel.Workbooks.Open(strXlFileName)
'Assign required worksheet to a variable
With objWorkbook
Set objWorksheet = .Worksheets(1)
End With
With objWorksheet
'Assign worksheet name to a string variable
strWorksheetName = .Name
End With
'Assign used range to a string variable.
strUsedRange = objWorksheet.Usedrange.Address(0, 0)
'Turn off/Close in reverse order to setting/opening.
'Check for target cell that indicates presence of CLIN data
On Error Resume Next
'This find command searches the used range for your header text
'Replace "One Time Price" with target header text
strTargetRow = objWorksheet.Range(strUsedRange).Find("One Time Price").Cells.Row
'This error appears if the target header text is not found
If Err.Number = 91 Then
MsgBox "CLIN Data was not found in " & strXlFileName & vbCr & _
"Check that CLIN listing is the first worksheet and that data format has not changed.", vbOKOnly, "Missing Data"
'If data is not found, close all open Excel workbooks and instances
objWorkbook.Close SaveChanges:=False
Set objWorkbook = Nothing
objExcel.Quit
Set objExcel = Nothing
Exit Sub
End If
'If no error, clear any errors and resume trapping
Err.Clear
On Error GoTo 0
strUsedRange1 = Mid(strUsedRange, 1, InStr(1, strUsedRange, ":", vbBinaryCompare) - 1)
strUsedRange2 = Mid(strUsedRange, InStr(1, strUsedRange, ":", vbBinaryCompare) + 1, Len(strUsedRange) - InStr(1, strUsedRange, ":"))
iPosition = GetPositionOfFirstNumericCharacter(strUsedRange1)
strUsedRange1Column = Mid(strUsedRange1, 1, iPosition - 1)
strUsedRange = strUsedRange1Column & strTargetRow & ":" & strUsedRange2
Set objCell = Nothing
Set objWorksheet = Nothing
'SaveChanges = False suppresses save message
objWorkbook.Close SaveChanges:=False
Set objWorkbook = Nothing
objExcel.Quit
Set objExcel = Nothing
'If the table already exists, linking again will create a duplicate.
'This prevents that from occurring.
'THIS LINE IDENTIFIES TARGET TABLE NAME
If ifTableExists("CLINs") = True Then
'MsgBox "Clins Exists!"
UpdateExcelLinkedTable (strWorksheetName & "$" & strUsedRange)
Else
'Import the worksheet - Change target table name ("CLINs" below)
'to match the table listed in the "ifTableExists" function call.
'If that is not changed then duplicates will be created each
'time this subroutine is run.
DoCmd.TransferSpreadsheet acLink, 8, "CLINs", _
strXlFileName, True, strWorksheetName & "!" & strUsedRange
End If
End If
MsgBox "CLIN data imported successfully!"
End Sub
This function allows an Access Macro to call the main sub. Only for user convenience
Public Function ImportClinData()
'Call Subroutine from here
ImportCLINDataSub
End Function
Thanks to Rob for a function that gets the position of the first numerical value in the string that is used to establish the range for the source data. This allows the macro to reset the target row down to the first row where the headers are detected.
Public Function GetPositionOfFirstNumericCharacter(ByVal s As String) As Integer
For i = 1 To Len(s)
Dim currentCharacter As String
currentCharacter = Mid(s, i, 1)
If IsNumeric(currentCharacter) = True Then
GetPositionOfFirstNumericCharacter = i
Exit Function
End If
Next i
End Function
Another borrowed function (thanks Karthik) that checks to see if my target table exists
Public Function ifTableExists(tblName As String) As Boolean
ifTableExists = False
If DCount("[Name]", "MSysObjects", "[Name] = '" & tblName & "'") = 1 Then
ifTableExists = True
End If
End Function
Big thank you to Gord Thompson for this one. This function updates the "SourceTableName" component of the connection string. Because the "SourceTableName" appears to be a read-only property, the target object must be cloned and then deleted. I don't believe that this will interfere with pre-existing references to the linked data...
Sub UpdateExcelLinkedTable(TargetSourceTableName As String)
Dim cdb As DAO.Database
Dim tbd As DAO.TableDef, tbdNew As DAO.TableDef
Dim n As Long
Const LinkedTableName = "CLINs"
Set cdb = CurrentDb
Set tbd = cdb.TableDefs(LinkedTableName)
Debug.Print "Current .SourceTableName is: " & tbd.SourceTableName
On Error Resume Next
n = DCount("*", LinkedTableName)
Debug.Print "The linked table is " & IIf(Err.Number = 0, "", "NOT ") & "working."
On Error GoTo 0
Set tbdNew = New DAO.TableDef
tbdNew.Name = tbd.Name
tbdNew.Connect = tbd.Connect
tbdNew.SourceTableName = TargetSourceTableName 'Replace this with new string
Set tbd = Nothing
cdb.TableDefs.Delete LinkedTableName
cdb.TableDefs.Append tbdNew
Set tbdNew = Nothing
Set tbd = cdb.TableDefs(LinkedTableName)
Debug.Print "Updated .SourceTableName is: " & tbd.SourceTableName
On Error Resume Next
n = DCount("*", LinkedTableName)
Debug.Print "The linked table is " & IIf(Err.Number = 0, "", "NOT ") & "working."
On Error GoTo 0
Set tbd = Nothing
Set cdb = Nothing
End Sub
