Excel VBA-根据一系列下拉列表运行宏

问题描述

自VBA上课已经有几年了，所以请像写一本 Excel VBA for Dummies那样回答。

It's been a few years since VBA class so please respond as if you were writing in an "Excel VBA for Dummies" book.

在G列中，G2：G1001范围内的每个单元格都是我的工作簿中所有工作表的单独数据验证下拉列表。我有一个宏，当您从单元格 G2的下拉列表中选择 Questar时，它会复制单元格A2：F2并将其粘贴到第一行空白行中名为 Questar的工作表中。一切正常。

In column G, each cell in range G2:G1001 is an individual data validation drop down list of all the worksheets in my workbook. I have a macro that when you select "Questar" from the dropdown in cell "G2", it copies cells A2:F2 and pastes them to the worksheet titled "Questar" in the first empty row. That all works fine.

但是，我的问题是它仅在单元格G2中有效。我在第2-1001行有数据，我需要它才能对所有单元格G2：G1001起作用。这是我到目前为止为单元格 G2工作的内容：

However, my issue is it only works in cell G2. I have data in rows 2-1001 and I need this to work for all cells G2:G1001. Here is what I have so far and works for cell "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 ）需要更改，但我已尝试了所有方法。

I think that the Select Case Range("G2") needs to change but I have tried everything.

这是我的Questar宏代码：

Here is my Questar macro code:

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

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

I will eventually add more cases but I want to get one worksheet working correctly before adding more cases and macros. Any suggestions?

推荐答案

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

EDIT: updated to single procedure, assuming all sheets exist which are named in column 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

这篇关于Excel VBA-根据一系列下拉列表运行宏的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！