如何在 VBA 中创建动态列表？

How to create a dynamic list in VBA?

提问by Nevermore

I have an excel sheet. I want to create a list which will be in 5 cells. For simplicity, lets call the items in the list as (item1, item2, item3, item4, item5). If I select "list1" from a cell-1, the item-contents in other list should become (item2, item3, item4, item5) and upon scrambled; the list should re-include the data into the list.

我有一个excel表。我想创建一个包含 5 个单元格的列表。为简单起见，我们将列表中的项目称为 (item1, item2, item3, item4, item5)。如果我从单元格 1 中选择“list1”，则其他列表中的项目内容应变为 (item2, item3, item4, item5) 并在加扰时；该列表应将数据重新包含在列表中。

I have tried the following:

我尝试了以下方法：

Sub PopulatingArrayVariable()
'PURPOSE: Dynamically Create Array Variable based on a Given Size

Dim myArray() As Variant
Dim DataRange As Range
Dim cell As Range
Dim x As Long

'Determine the data you want stored
 Set DataRange = ActiveSheet.UsedRange

'Resize Array prior to loading data
ReDim myArray(DataRange.Cells.Count)

'Loop through each cell in Range and store value in Array
For Each cell In DataRange.Cells
  myArray(x) = cell.Value
  x = x + 1
Next cell

End Sub

Example:

例子：

Suppose there are 3 cells A, B, C. All these cells will have this list ( Consider this as a list that we see in data-validation or a static array). So, our cells will have the values in the list like ( NY, NJ, LA ). Once we select an element (NY) from cell A, the remaining elements of list to be shown in cell B, C should be ( NJ, LA). If this NY is selected by any other cell then it should not show up in cell B, C.

假设有 3 个单元格 A、B、C。所有这些单元格都将具有此列表（将其视为我们在数据验证或静态数组中看到的列表）。因此，我们的单元格将具有列表中的值，例如 ( NY, NJ, LA )。一旦我们从单元格 A 中选择了一个元素 (NY)，要在单元格 B、C 中显示的列表的其余元素应该是 (NJ, LA)。如果此 NY 被任何其他单元格选中，则它不应出现在单元格 B、C 中。

回答by TheSilkCode

So little confused as to what you mean by "If I select "list1" from a cell-1, the item-contents in other list should become (list2, list3, list4, list5) and upon scrambled; the list should re-include the data into the list.".. but to write a sub to populate a 1D array with a sheets used range you are very close- in fact I think you code should work with just 1 simple change:

对“如果我从单元格 1 中选择“list1”的意思感到困惑，其他列表中的项目内容应变为 (list2, list3, list4, list5) 并在加扰后；该列表应重新包括将数据添加到列表中。”...但是要编写一个子程序来填充一个一维数组，其中使用的工作表范围非常接近 - 事实上，我认为您的代码应该只进行 1 个简单的更改即可工作：

Sub PopulatingArrayVariable()
'PURPOSE: Dynamically Create Array Variable based on a Given Size

Dim myArray() As Variant
Dim DataRange As Range
Dim cell As Range
Dim x As Long

'Determine the data you want stored
 Set DataRange = ActiveSheet.UsedRange

'Resize Array prior to loading data
ReDim myArray(DataRange.Cells.Count)

'Loop through each cell in Range and store value in Array
For Each cell In DataRange.Cells
  x = x + 1
  myArray(x) = cell.Value
Next cell

End Sub

A couple things I will say however, 1) it is a good idea to use Option Explicit- it has saved me from a ton of coding mistakes that I potentially wouldn't have found until after hours of excruciating troubleshooting... 2) If you were to use Option Explicit and could no longer use For Each cell In DataRange.Cellssyntax, this is how would re-write the sub:

但是，我要说几件事，1) 使用 Option Explicit 是个好主意 - 它使我免于大量编码错误，直到经过数小时的痛苦的故障排除后，我才可能发现这些错误...... 2) 如果您将使用 Option Explicit 并且不能再使用For Each cell In DataRange.Cells语法，这是重写子程序的方法：

Sub PopulatingArrayVariableVersion2()
'PURPOSE: Dynamically Create Array Variable based on a Given Size

Dim myArray() As Variant
Dim tempArr() As Variable 'Temp Array to read in data range
Dim DataRange As Range
Dim rowCounter As Long 'For looping through tempArr's Rows
Dim colCounter As Long 'For looping through tempArr's Cols
Dim arrWriter As Long 'Need additional variable to store the element of array to write to

'Determine the data you want stored
 Set DataRange = ActiveSheet.UsedRange

'Resize Array prior to loading data
ReDim myArray(DataRange.Cells.Count)
tempArr = DataRange 'Load in DataRange as array

'Loop through row,col in tempArr and store value in Array
For rowCounter = 1 To UBound(tempArr, 1)
    For colCounter = 1 To UBound(tempArr, 2)
        arrWriter = arrWriter + 1
        myArray(arrWriter) = tempArr(rowCounter, colCounter)
    Next
Next

End Sub

Also I think using an array instead of reading from a range each time will end up being faster-

此外，我认为使用数组而不是每次从范围读取最终会更快-

Hope this helps, TheSilkCode

希望这会有所帮助，TheSilkCode

回答by TheSilkCode

Okay now I see what you are trying to do- you are trying to populate a cells data validation drop down list with the values from another sheets used range... So you are on the right track but the issue is that data validation actually expects a string with elements comma delimited, not an array... so the final code would look like:

好的，现在我明白您要做什么 - 您正在尝试使用另一个工作表使用范围中的值填充单元格数据验证下拉列表...所以您走在正确的轨道上，但问题是数据验证实际上需要一个以逗号分隔元素的字符串，而不是一个数组......所以最终的代码看起来像：

Public Sub setValidationList()
Dim targetCell As Range
Set targetCell = ThisWorkbook.Sheets(1).Range("A1")
With targetCell.Validation
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=getValidationList
End With
End Sub

Public Function getValidationList() As String
Dim dataRange As Range
Dim listStr As String
Dim tempArr() As Variant 'Temp Array to read in data range
Dim rowCounter As Long 'For looping through tempArr's Rows
Dim colCounter As Long 'For looping through tempArr's Cols

Set dataRange = ThisWorkbook.Sheets("Sheet1").UsedRange
tempArr = dataRange

'Loop through row,col in tempArr and store value in Array
For rowCounter = 1 To UBound(tempArr, 1)
    For colCounter = 1 To UBound(tempArr, 2)
        listStr = listStr & IIf(listStr <> "", ",", "") & CStr(tempArr(rowCounter, colCounter))
    Next
Next
getValidationList = listStr
End Function

Hope this helps, TheSilkCode

希望这会有所帮助，TheSilkCode

回答by user3598756

editedto add the code of GetRangeFromValidationFormula()function (previously named GetRange())

编辑以添加GetRangeFromValidationFormula()函数代码（以前命名为GetRange()）

as per your example added in your question, you may try to add the following code in the relevant worksheet code pane:

根据您在问题中添加的示例，您可以尝试在相关工作表代码窗格中添加以下代码：

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim listRng As Range, validationRng As Range, cell As Range, cell2 As Range
    Dim changedValue As String

    Set listRng = Range("A1:A3") '<--| this are your "3 cells A, B, C"

    If Not Intersect(Target, listRng) Is Nothing Then
        changedValue = Target.value
        Set validationRng = GetRangeFromValidationFormula(Target.Validation.Formula1)

        Application.EnableEvents = False
        On Error GoTo ExitSub
        listRng.ClearContents
        For Each cell In listRng
            If cell.Address = Target.Address Then
                cell.value = changedValue
            Else
                For Each cell2 In validationRng
                    If listRng.Find(what:=cell2.value, LookIn:=xlValues, lookat:=xlWhole) Is Nothing And cell2.value <> changedValue Then
                        cell.value = cell2.value
                        Exit For
                    End If
                Next
            End If
        Next
    End If

ExitSub:
    Application.EnableEvents = True
End Sub


Function GetRangeFromValidationFormula(validationFormula As String) As Range
    Dim list As Variant
    list = VBA.Split(Replace(ActiveCell.Validation.Formula1, "=", ""), "!")

    If UBound(list) > 0 Then
        Set GetRange = Worksheets(list(0)).Range(list(1))
    Else
        Set GetRange = Range(list(0))
    End If
End Function