好的，自我回答。
- 此子例程检查链接表是否已存在，如果存在则更新该表。
- Excel 电子表格上的数据可以移动。只要目标标题列始终存在，则此宏将找到包含标题的第一行。
- 它利用了 excel 的“使用范围”功能，该功能并不总是 100% 准确，但在我的情况下似乎运行良好。
如果修改此代码：
- 请务必修改此代码中的目标表名称和目标标题文本以匹配您的 Excel 文件。
- 确保目标标题文本在 Excel 文件中没有重复，并且与其他标题位于同一行。
- 目标标题文本的行用作目标范围的起始行
- 确保您的目标工作表是工作簿中的第一个工作表。
感谢this tek-tips post 提供此代码的基础。我不是专家，但这完成了我打算做的事情。我确信这段代码可以进一步简化。
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
此函数允许访问宏调用主子。只为方便用户
Public Function ImportClinData()
'Call Subroutine from here
ImportCLINDataSub
End Function
感谢 Rob 在用于建立源数据范围的字符串中提供function that gets the position of the first numerical value。这允许宏将目标行重置为检测到标题的第一行。
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
另一个借用函数 (thanks Karthik) 检查我的目标表是否存在
Public Function ifTableExists(tblName As String) As Boolean
ifTableExists = False
If DCount("[Name]", "MSysObjects", "[Name] = '" & tblName & "'") = 1 Then
ifTableExists = True
End If
End Function
非常感谢Gord Thompson for this one。此函数更新连接字符串的“SourceTableName”组件。因为“SourceTableName”似乎是一个只读属性，所以必须克隆目标对象，然后再删除。我认为这不会干扰对链接数据的预先存在的引用...
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