循环显示工作表，将值添加到下拉列表并使列表动态 - VBA

Goal

我想循环浏览三张表，并根据一些要求在另一张表中填充In-cell下拉列表（类似于数据验证设置中的下拉列表） . 三张表中的任何更改都应该影响下拉列表，而用户不必运行宏 - 换句话说，列表需要是动态的 .

Problem

我已使用所有三张表中的数据填充下拉列表 . 我有三个问题：

1）对于某些列 lastRow 未正确计算

2）代码太慢（大约需要10秒）

3）生成的下拉列表不是动态的 .

Description

在第六张（下拉表）中，列E包含我想要与五张纸中的第一行（E1：GG1）进行比较的名称 . 每列都有一堆1 .

如果E列（下拉列表）中的名称与行中的名称（五个表格中的一个）之间存在匹配，并且该行的列中存在“1”，则下拉列表应填充ID在A栏中

Example of individual sheet and desired output

Code

Public MyArray() As Variant

Sub Commandbutton_click()

    Dim TeamSource As Range, PersonSource As Range
    Dim PersonCell As Range, TeamCell As Range
    Dim ws As Worksheet

    Dim i As Integer
    Dim indx As Integer
    Dim lastRow As Integer

    Set TeamSource = Sheets("Dropdown Sheet").Range("E10:E100")

    On Error Resume Next

    For Each ws In ThisWorkbook.Worksheets

    Set PersonSource = ws.Range("E1:GG1")

        If ws.Name = "sheet1" Or ws.Name = "sheet2" Or ws.Name = "sheet3" Then

            For Each PersonCell In PersonSource
                v = PersonCell.Value
                With PersonSource
                    lastRow = .Cells(.Rows.Count, PersonCell.Columns.Count).End(xlUp).Row
                End With
                    If v <> "" Then
                        For Each TeamCell In TeamSource
                            If PersonCell = TeamCell Then
                            intValueToFind = 1
                                For i = 1 To lastRow
                                    If PersonCell.Offset(i, 0) = intValueToFind Then
                                        ReDim Preserve MyArray(i)
                                        MyArray(i) = PersonCell.Offset(i, -PersonCell.Column + 1)
                                        Debug.Print Join(MyArray, ", ")
                                        With TeamCell.Offset(0, 1).Validation
                                            .Delete
                                            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                                            Operator:=xlBetween, Formula1:=Join(MyArray, ",")
                                            .IgnoreBlank = True
                                            .InCellDropdown = True
                                            .InputTitle = ""
                                            .ErrorTitle = ""
                                            .InputMessage = ""
                                            .ErrorMessage = ""
                                            .ShowInput = True
                                            .ShowError = True
                                        End With
                                    End If
                                Next i
                            End If
                        Next TeamCell
                    End If
            Next PersonCell
        End If
    Next ws

End Sub