请注明“；开放式；使用VBA从MS Access链接excel电子表格中的范围

这个问题直接涉及到

• 我希望将MS Access中随机放置的数据范围作为MS Excel电子表格的目标，并在链接表中使用它
• 该范围必须能够改变位置并向下扩展

在不修改目标excel电子表格和创建命名范围的情况下，我是否可以在电子表格中为access中的链接表指定一个范围，该范围从目标单元格/行开始，到最右下角的单元格/行结束？VBA宏可能很适合此任务（类似于链接示例中的宏）

或者，是否有办法让MS Access分析目标电子表格，找到最上面一行最左边的单元格，然后确定最下面一行最右边的单元格在哪里？几乎像

Application.ActiveSheet.UsedRange

。然后，该范围将用作链接表的目标

电子表格由另一个组织发布，并定期更换。因此，发布新版本的电子表格时，将删除其中的任何命名范围

我计划将此功能添加到数据库中，该数据库将提供给可能不了解如何修改链接文件的用户。也就是说，顶部的两行或三行是不需要的，但电子表格始终会添加额外的行。我想给他们一个宏，只需重新链接更新后的电子表格，而无需更改电子表格本身的格式。

好的，自我回答

• 此子例程检查链接表是否已存在，如果已存在，则更新该表
• Excel电子表格上的数据可以四处移动。只要目标标题列始终存在，则此宏将找到包含标题的第一行
• 它利用了excel的“使用范围”功能，虽然并非总是100%准确，但在我的情况下，它似乎工作得很好

如果修改此代码：

• 确保在此代码中修改目标表名和目标标题文本，以匹配Excel文件
• 确保目标标题文本在excel文件中没有重复，并且与其他标题位于同一行
• 目标标题文本的行用作目标范围的起始行
• 确保目标工作表是工作簿中的第一个工作表

感谢您提供此代码的基础。我不是专家，但这完成了我开始做的事情。我相信这段代码可以进一步简化

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

此功能允许Access宏调用main sub。仅为方便用户

Public Function ImportClinData()
    'Call Subroutine from here
    ImportCLINDataSub
End Function

感谢Rob在用于建立源数据范围的字符串中添加了一个。这允许宏将目标行重置为检测到标题的第一行

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

另一个借用的函数（）检查目标表是否存在

Public Function ifTableExists(tblName As String) As Boolean

ifTableExists = False
If DCount("[Name]", "MSysObjects", "[Name] = '" & tblName & "'") = 1 Then
ifTableExists = True
End If

End Function

非常感谢你。此函数用于更新连接字符串的“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

---

我一直使用动态名称范围，方法是使用如下公式设置命名范围，使用范围的标题行和第一列作为定位点，如下所示： =偏移量（A1,1,0，计数A（A:A）-1,8） 还可以使用COUNTA设置列的宽度。限制在于，除非您可以在公式上进行调整，否则您使用的列中只能有表格数据，例如，上面显示的公式计算的是文本行数减去标题行数。只要列中的其他值为常量，就可以增加该值。如果列值是数字（而标题不是），也可以使用COUNT而不是COUNTA。

---

只要列是干净的，您就可以链接到名称范围，该范围将自动调整为表中的数字或行（以及使用COUNTA函数设置的列）。

请参阅，但是只要不需要的行/列为空，Access就可以非常智能地处理行/列。问题似乎在于消除标题上方不需要的行。至少有一个单元格中有文本，这会使导入功能失效。。。我正在寻找一些示例宏，希望我能创建一些这样做的东西，希望有一个简单、快速的方法！谢谢你的链接！