Question

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

我尝试了以下内容：

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

示例：

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

Answer 1

如果我选择＆＃34; list1＆＃34;那么很少会对你的意思感到困惑。从一个单元格1开始，其他列表中的项目内容应该变为（list2，list3，list4，list5）并且在加扰时;列表应该将数据重新包含在列表中。＆＃34; ..但要编写一个子来填充一个单独的数组，其中使用的工作表范围非常接近 - 事实上我认为你的代码应该只用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

我会说几件事情，1）使用Option Explicit是一个好主意 - 它让我免于大量的编码错误，这些错误在我经过几个小时的难以理解的故障排除之后才可能找不到。 .. 2）如果你使用Option Explicit并且不能再使用For Each cell In DataRange.Cells语法，那么这将是如何重写sub：

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

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

希望这有帮助， TheSilkCode

Answer 2

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

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

希望这有帮助， TheSilkCode

Answer 3

已修改以添加GetRangeFromValidationFormula()功能代码（以前称为GetRange()）

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

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

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

3 个答案: