vb, combobox, RefersToRange, Dynamic Named Ranges

Question

Может кто-нибудь может помочь решить проблему с ReferToRange в моем коде. Я привел пример. Я получаю ошибку 1041 времени выполнения, определенную или объектно определенную ошибку при вызове MAIN. Я связываю список combobox 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