更新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