excel - vb、组合框、RefersToRange、动态命名范围

Question

任何人都可以请帮助解决我的代码中的 ReferToRange 问题。我附上了一个例子。调用 MAIN 时，我收到运行时错误 1041 应用程序定义或对象定义错误。我根据单元格的值将组合框 listfillrange 链接到 3 个命名范围。这三个范围是动态的（有一个偏移公式）。组合框与命名范围不同请帮助

Sub MAIN()
Dim PT As Range
Dim i As Long

With Sheet3  ' Unique SPP
    setNames .Range("a6")
    Set PT = .Range("b1")
    i = 1
    Do Until PT = ""
        If .Range("a1").Value = PT.Value Then
            On Error Resume Next
            Sheet1.ComboBox1.ListFillRange = ThisWorkbook.Names("view" & i).Name
            If Err.Number = 1004 Then
                MsgBox "not defined name: view" & i
            ElseIf Err.Number <> 0 Then
                MsgBox "unexpected error: " & Err.Description
            End If
            On Error GoTo 0
        End If
        i = i + 1
        Set PT = PT.Offset(0, 1)
    Loop
End With
End Sub

Sub setNames(theTopLeft As Range)
    Dim theName As Name
    Dim nameStr As String
    Dim theRng As Range
    Dim i As Long
    Application.DisplayAlerts = False
    theTopLeft.CurrentRegion.CreateNames Top:=True, Left:=False, _
                Bottom:=False, Right:=False
    Application.DisplayAlerts = True
    For Each theName In ThisWorkbook.Names
        With theName.RefersToRange.Value
            For i = .Cells.Count To 1 Step -1
                If .Cells(i) <> "" Then Exit For
            Next
        End With
        If i <> 0 Then theName.RefersTo = theName.RefersToRange.Resize(i, 1)
    Next
End Sub

Answer 1

在我看来，您的代码比必要的要复杂一些。因此，如果我正确理解您要执行的操作，那么这应该符合要求。

Sub MAIN()

Dim rC As Range
Dim rD As Range
Dim i As Long
Dim s As String

On Error GoTo errTrap

With Sheet3 'change to suit
    s = .Range("a1") 'heading to find
    Set rD = .Range("A6", .Cells.SpecialCells(xlCellTypeLastCell)) 'data row 6 and down
    Set rD = rD.Resize(, 3) '1st 3 columns only, change if required
    i = Application.Match(s, rD.Rows(1).Cells, 0) 'find heading
    Set rC = rD.Columns(i).Offset(1).Cells 'drop heading from column
    Set rC = .Range(rC(1), .Cells(.Rows.Count, rC.Column).End(xlUp)) 'to end of data
'       if column contains data, fill combo
    If rC(1).Row > rD.Row Then Sheet1.ComboBox1.ListFillRange = .Name & "!" & rC.Address
End With
Exit Sub
errTrap:
If Err.Number = 13 Then
    MsgBox "heading not found:  " & s
Else
    MsgBox "unexpected error: " & Err.Description
End If

End Sub