Excel VBA从工作表中的公式创建一个命名范围

Question

您好，我的一些 VBA 代码有问题。

我正在制作一个多动态表，以帮助我保持对程序的控制。 因此，当我调整表格中的某些内容时，我可以使用此代码来更新我的所有代码。

在表格中，我使用这段代码来定位我需要的数据，到目前为止效果很好。

Source_1_Criteria = "Factuur"
Source_1 = Range("MDM_MDM_Tool_List").Find(what:=Source_1_Criteria).Offset(0, 1).Value

Me.ListBox1.RowSource = Source_1

现在我想使用相同的代码和一些额外的代码来创建一个命名范围。 这在我使用只有一些文本的单元格时有效，但是当我用公式填充单元格时，VBA 会引发错误。

Source_1_Criteria = "Factuur"
Source_1_Name = Range("MDM_MDM_Tool_List").Find(what:=Source_1_Criteria).Offset(0, 2).Value
Source_1_Area = Range("MDM_MDM_Tool_List").Find(what:=Source_1_Criteria).Offset(0, 4).Value

ActiveWorkbook.Names.Add Name:=Source_1_Name, RefersTo:=Source_1_Area

范围 Source_1_Area 的内容是

=VERSCHUIVING(archief!$A$2;0;0;1;AANTALARG(archief!$A$3:$Y$3))

当我将 =archief!$A$2 放入内容中时，我使用的代码确实有效

为什么我的大公式不起作用？

Answer 1

这将使用您在命名范围中提供的公式

Sub Test()

    AllocateNamedRange ThisWorkbook, "SomeName", "=VERSCHUIVING(archief!$A$2;0;0;1;AANTALARG(archief!$A$3:$Y$3))", "A1"

    'English version:
    'AllocateNamedRange ThisWorkbook, "SomeName", "=OFFSET(archief!$A$2,0,0,1,COUNTA(archief!$A$3:$Y$3))", "A1"

End Sub

Sub Test2()

    'Using some of your code to find the name.
    Dim rFoundRange As Range

    With ThisWorkbook.Worksheets("Sheet1").Range("MDM_MDM_Tool_List")
        Set rFoundRange = .Find(what:=Source_1_Criteria)

        'If Source_1_Criteria isn't found it will throw an error so need to check if it's found first.
        If Not rFoundRange Is Nothing Then
            AllocateNamedRange ThisWorkbook, rFoundRange.Offset(0, 2).Value, _
                "=VERSCHUIVING(archief!$A$2;0;0;1;AANTALARG(archief!$A$3:$Y$3))", "A1"
        End If

    End With

End Sub

'---------------------------------------------------------------------------------------
' Procedure : AllocateNamedRange
' Purpose   : Deletes the named range if it already exists and then recreates it.
'---------------------------------------------------------------------------------------
Public Sub AllocateNamedRange(Book As Workbook, sName As String, sRefersTo As String, Optional ReferType = "R1C1")
    With Book
        If NamedRangeExists(Book, sName) Then .Names(sName).Delete
            If ReferType = "R1C1" Then
                .Names.Add Name:=sName, RefersToR1C1:=sRefersTo
        ElseIf ReferType = "A1" Then
                .Names.Add Name:=sName, RefersTo:=sRefersTo
        End If
    End With
End Sub

'---------------------------------------------------------------------------------------
' Procedure : NamedRangeExists
' Purpose   : Checks if a named range exists.  Returns TRUE or FALSE.
'---------------------------------------------------------------------------------------
Public Function NamedRangeExists(Book As Workbook, sName As String) As Boolean
    On Error Resume Next
        NamedRangeExists = Book.Names(sName).Index <> (Err.Number = 0)
    On Error GoTo 0
End Function

您可以将公式硬编码到一个命名范围内，它会在您添加新数据时自动调整（基本上是我的代码所做的）。