在使用 VBA 的 MS Access 链接的 Excel 电子表格中指定“开放式”范围

Posted 2023-04-19

【中文标题】在使用 VBA 的 MS Access 链接的 Excel 电子表格中指定“开放式”范围

【英文标题】：Specify "open ended" range in linked excel spreadsheet from MS Access with VBA

【发布时间】：2014-02-05 15:22:57

【问题描述】：

这个问题与MS Access: Link to Excel file with header on row X > 1?直接相关

我想在 MS Access 的 MS Excel 电子表格中定位随机放置的数据范围，并在链接表中使用它。 范围必须能够改变位置和向下增长。

如果不修改目标 Excel 电子表格并创建命名范围，我能否以某种方式在电子表格上为访问中的链接表指定一个范围，该范围从目标单元格/行开始并在最右下角的单元格/行结束？ VBA 宏可能很适合此任务（类似于链接示例中的一个）。

或者，有没有办法让 MS Access 分析目标电子表格，找到顶行最左边的单元格，然后确定底行最右边的单元格在哪里？几乎就像Application.ActiveSheet.UsedRange。然后，此范围将用作链接表的目标。

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

我计划将此功能添加到数据库中，该功能将提供给可能不了解如何修改链接文件的用户。 IE。不需要前两行或前三行，但电子表格一直都添加了其他行。我想给他们一个宏，它可以简单地重新链接更新后的电子表格，而无需更改电子表格本身的格式。

【问题讨论】：

请参阅msdn.microsoft.com/en-us/library/office/gg264813.aspx，但只要您不需要的行/列为空，Access 对行/列非常智能。

似乎消除标题上方不需要的行是问题所在。至少有一个单元格中有文本，它会抛出导入函数......我正在寻找一些示例宏，希望我可以创建一些可以做到这一点的东西，希望有一种简单、快速的方法！感谢您的链接！

【参考方案1】：

好的，自我回答。

此子例程检查链接表是否已存在，如果存在则更新该表。 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

【参考方案2】：

我一直使用动态名称范围，方法是使用这样的公式设置命名范围，使用标题行和范围的第一列作为锚点，如下所示： =OFFSET(A1,1,0,COUNTA(A:A)-1,8) 您还可以使用 COUNTA 设置列的宽度。限制是除了您正在使用的列中的表格数据之外，必须没有其他任何内容，除非您可以在公式上对其进行调整，例如上面显示的公式计算文本行数，减去标题行。只要它是恒定的，您就可以为列中的其他值增加它。如果列值是数字（而标题不是），您也可以使用 COUNT 而不是 COUNTA。 只要该列是干净的，您就只需链接到名称范围，该范围将自动调整为表中的数量或行（如果使用 COUNTA 函数设置，则为列）。