vba - 排序宏和数据验证宏

Question

我的计划是在特定工作表(列表)上输入数据并按字母顺序自动排序，然后在第一张工作表(TicketSheet)上创建数据验证。


当我输入任何日期并保存时，我无法再次打开文件，因为它崩溃了。

我开发了以下代码:

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("$A:$F")) Is Nothing Then


    Dim x As Range
    Set x = Cells(2, Target.Column)
    Dim y As Range
    Set y = Cells(1000, Target.Column)


    If Target.Column = 1 Or Target.Column = 4 Or Target.Column = 6 Then
    Range(x, y).Sort Key1:=Target, Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

    End If
    End If

    Call AddData
    Call AddData1
    Call AddData2


End Sub


Sub AddData()

Dim Lrow As Single
Dim Selct As String
Dim Value As Variant

Lrow = Worksheets("List").Range("A" & Rows.Count).End(xlUp).Row

For Each Value In Range("A2:A" & Lrow)
    Selct = Selct & "," & Value

Next Value


Selct = Right(Selct, Len(Selct) - 1)

With Worksheets("TicketSheet").Range("C4").Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
    xlBetween, Formula1:=Selct
    .IgnoreBlank = True
    .InCellDropdown = True
    .InputTitle = ""
    .ErrorTitle = ""
    .InputMessage = ""
    .ErrorMessage = ""
    .ShowInput = True
    .ShowError = True
End With

End Sub


Sub AddData1()


Dim Lrow1 As Single
Dim Selct1 As String
Dim Value As Variant


Lrow1 = Worksheets("List").Range("D" & Rows.Count).End(xlUp).Row


For Each Value In Range("D2:D" & Lrow1)
    Selct1 = Selct1 & "," & Value

Next Value


Selct1 = Right(Selct1, Len(Selct1) - 1)


With Worksheets("TicketSheet").Range("C3").Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
    xlBetween, Formula1:=Selct1
    .IgnoreBlank = True
    .InCellDropdown = True
    .InputTitle = ""
    .ErrorTitle = ""
    .InputMessage = ""
    .ErrorMessage = ""
    .ShowInput = True
    .ShowError = True
End With
End Sub

Sub AddData2()


Dim Lrow2 As Single
Dim Selct2 As String
Dim Value As Variant


Lrow2 = Worksheets("List").Range("F" & Rows.Count).End(xlUp).Row


For Each Value In Range("F2:F" & Lrow2)
    Selct2 = Selct2 & "," & Value

Next Value


Selct2 = Right(Selct2, Len(Selct2) - 1)


With Worksheets("TicketSheet").Range("C5").Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
    xlBetween, Formula1:=Selct2
    .IgnoreBlank = True
    .InCellDropdown = True
    .InputTitle = ""
    .ErrorTitle = ""
    .InputMessage = ""
    .ErrorMessage = ""
    .ShowInput = True
    .ShowError = True
End With
End Sub]

Answer 1

首先，您需要禁用事件。 Worksheet_Change事件宏由值的变化触发。如果您要开始更改 Worksheet_Change 中的值，则禁用事件会阻止宏自行触发。

此外，目标 是已更改的一个或多个单元格。您的代码不允许后者；它只处理 Target 是单个单元格的情况。暂时，丢弃较大的更改(如行删除或排序操作中的更改)。

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Count > 1 Then Exit Sub

    If Not Intersect(Target, Range("$A:$F")) Is Nothing Then
        On Error GoTo bm_Safe_Exit
        Application.EnableEvents = False
        Dim x As Range, y As Range
        Set x = Cells(2, Target.Column)
        Set y = Cells(1000, Target.Column)

        If Target.Column = 1 Or Target.Column = 4 Or Target.Column = 6 Then
            'you really should know if you have column header labels or not
            Range(x, y).Sort Key1:=Target, Order1:=xlAscending, _
                             Header:=xlGuess, OrderCustom:=1, _
                             MatchCase:=False, Orientation:=xlTopToBottom
            Call AddData
            Call AddData1
            Call AddData2
        End If
    End If

bm_Safe_Exit:
    Application.EnableEvents = True
End Sub

那应该让你开始。稍后我将深入研究您的其他子程序，但我会指出，您似乎有很多事情要由 Worksheet_Change 启动。