Excel VBA - 基于一系列下拉列表运行宏

Question

VBA 课程已经有好几年了，所以请像在“Excel VBA for Dummies”一书中写一样回答。

在 G 列中，范围 G2:G1001 中的每个单元格都是我工作簿中所有工作表的单独数据验证下拉列表。我有一个宏，当您从单元格“G2”的下拉列表中选择“Questar”时，它会复制单元格 A2:F2 并将它们粘贴到第一个空行中标题为“Questar”的工作表中。这一切都很好。

但是，我的问题是它仅适用于单元格 G2。我在第 2-1001 行有数据，我需要它来处理所有单元格 G2:G1001。这是我到目前为止所拥有的，适用于单元格“G2”：

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("G2:G1001")) Is Nothing Then
        Select Case Range("G2")
            Case "Questar": Questar
        End Select
    End If
End Sub

我认为 Select Case Range("G2") 需要更改，但我已经尝试了所有方法。

这是我的 Questar 宏代码：

Sub Questar()

    Worksheets("AFCU Auto-Add").Range(ActiveCell.Offset(0, -6), ActiveCell.Offset(0, -1)).Copy
    Worksheets("Questar").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

    Sheets("AFCU Auto-Add").Select
    Range(ActiveCell.Offset(0, -6), ActiveCell.Offset(0, -1)).Select
    Application.CutCopyMode = False
    Selection.ListObject.ListRows(1).Delete
    Range("G2").Select

End Sub

我最终会添加更多案例，但我希望在添加更多案例和宏之前让一个工作表正常工作。有什么建议么？

Answer 1

编辑：更新为单个过程，假设存在所有在 G 列中命名的工作表...

类似：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range, c As Range, rngDel As Range

    On Error GoTo haveError

    Set rng = Intersect(Target, Range("G2:G1001"))

    If Not rng Is Nothing Then
        For Each c In rng.Cells
            If Len(c.Value) > 0 Then
                'copy to appropiate sheet
                With ThisWorkbook.Worksheets(c.Value).Cells(Rows.Count, 1).End(xlUp)
                    .Offset(1, 0).Resize(1, rng.Cells.Count).Value = _
                                     c.EntireRow.Range("A1:F1").Value
                End With

                'build up a range of rows to delete...
                If rngDel Is Nothing Then
                    Set rngDel = c
                Else
                    Set rngDel = Union(c, rngDel)
                End If

            End If
        Next c

        'any rows to delete?
        If Not rngDel Is Nothing Then
            Application.EnableEvents = False
            rngDel.EntireRow.Delete
            Application.EnableEvents = True
        End If

    End If

    Exit Sub

haveError:
    'make sure to re-enable events in the case of an error
    Application.EnableEvents = True

End Sub