對宏和數據驗證宏進行排序

Question

我的計劃是在特定工作表（List）中輸入數據，並按字母順序自動排序，然後在第一個工作表（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啓動的。