更新ActiveWorkbook.Names（「X」）。VBA中的RefersTo和Names.Value

Question

我有一些代碼當前通過表格查看任何單元格，我用淺灰色填充，然後在該單元格中添加值到名稱列表。目標是在工作簿中的其他地方，我可以將此列表作爲下拉列表引用。

這裏是我當前的代碼：

Sub Add_Food_To_List() 
    i = 1 
    Application.ScreenUpdating = False 
    Range("a1:a60").Select 
    x = "{" 
    y = "" 
    first = True 
    For Each Cell In Selection 
    If ActiveCell.Interior.ColorIndex = "2" Then 
     i = i + 1 
     If first = False Then 
     x = x & ", " & ActiveCell.Value 
     y = y & ", " & ActiveCell.Address 
     End If 
     If first Then 
     x = x & ActiveCell.Value 
     y = y & ActiveCell.Address 
     first = False 
     End If 
     ActiveWorkbook.Names("Foods").RefersTo = y 
     ActiveWorkbook.Names("Foods").Value = x 
    End If 
    ActiveCell.Offset(1, 0).Select 
    Next Cell 
    Range("a1").Select 
    Application.ScreenUpdating = True 
End Sub 

出於某種原因，For Each Cell In Selection內這兩條線：

ActiveWorkbook.Names("Foods").RefersTo = y 
    ActiveWorkbook.Names("Foods").Value = x 

相互覆蓋。無論哪一個最終都會以名稱中的RefersTo AND Value設置的值結束。

獎勵：這是我的第一個VBA腳本。我怎樣才能讓這個腳本在整個工作簿上運行，而不僅僅是活動工作表？另外，如何在保存或工作簿更新時自動運行它？

Answer 1

也許這將更好地爲您服務：

1. 在您的工作簿的名稱Reference創建一個工作表。
2. 在單元格A1中輸入Foods並在單元格A2中放入至少一個隨機食物。
3. 使用以下公式創建一個名稱爲Foods的定義：=offset(A2,0,0,counta(A:A)-1,1)這是一個Dynamic Named Ranges，它將隨着行的添加或刪除而展開或收縮（只需確保數據之間沒有空白行）。
4. 將下面的代碼放在VBE中的ThisWorkbook模塊中。下面的代碼將在Workbook保存之前運行。它將遍歷每個工作表，並將Range(A1:A60)中突出顯示爲灰色的任何單元格的值添加到現有行集合正下方的Reference Worksheet的A列中的行集。

代碼模塊：

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) 

    Application.ScreenUpdating = False 

    Dim ws As Worksheet 

    For Each ws In ThisWorkbook.Worksheets 

     If ws.Name <> "Reference" Then 

      With ws 

       Dim rCell As Range 
       For Each rCell In .Range("a1:a60") 

        If rCell.Interior.ColorIndex = "2" Then 

         Dim wsRef As Worksheet 
         Set wsRef = Sheets("Reference") 
         If wsRef.Range("Foods").Find(rCell.Value, lookat:=xlWhole) Is Nothing Then 
          wsRef.Range("A" & wsRef.Rows.Count).End(xlUp).Offset(1).Value = rCell.Value2 
         End If 
        End If 

       Next 

      End With 

     End If 

    Application.ScreenUpdating = True 


End Sub