在VBA中更新ActiveWorkbook.Names("X").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和value设置为名称中的值。

奖励:这是我的第一个VBA脚本。如何让这个脚本在整个工作簿上运行，而不仅仅是在活动工作表上运行呢？此外，如何使它在保存或工作簿更新时自动运行？

Answer 1

也许这会更好地为你服务：

1. 在工作簿中创建一个名为Reference的工作表。
2. 在细胞Foods中键入A1，并在细胞A2中放置至少一种随机食物。
3. 使用以下公式创建Foods的定义名称：=offset(A2,0,0,counta(A:A)-1,1) --这是一个随着行的添加或删除而展开或收缩的动态命名范围 (只需确保数据之间没有空行)。
4. 将下面的代码放在VBE的ThisWorkbook模块中。下面的代码将在工作簿保存之前运行。它将循环遍历每个工作表，并将Range(A1:A60)中任何突出显示为灰色的单元格的值直接添加到Reference工作表第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