需要清除带有多行的订单表单上的If Not Intersect Is Nothing代码



VBA新手。想知道如何提高代码的效率。

我已经创建了一个包含50个订单行的订单,即您最多可以使用此表单订购50个项目。每个项目都有3个可能的自定义项,这些自定义项将确定产品SKU。我已经编写了以下代码;重置";如果您更改每行的项目选择(仅显示前3行的代码,但对所有50行重复此操作(,则会显示自定义选项。如有任何帮助,我们将不胜感激。

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("L1RoomType")) Is Nothing Then
Range("L1Dis").Value = Range("L1DisDefault").Value
End If
If Not Intersect(Target, Range("L1RoomType")) Is Nothing Then
Range("L1Pwr").Value = Range("L1PwrDefault").Value
End If
If Not Intersect(Target, Range("L1RoomType")) Is Nothing Then
Range("L1TM").Value = Range("L1TMDefault").Value
End If
If Not Intersect(Target, Range("L2RoomType")) Is Nothing Then
Range("L2Dis").Value = Range("L2DisDefault").Value
End If
If Not Intersect(Target, Range("L2RoomType")) Is Nothing Then
Range("L2Pwr").Value = Range("L2PwrDefault").Value
End If
If Not Intersect(Target, Range("L2RoomType")) Is Nothing Then
Range("L2TM").Value = Range("L2TMDefault").Value
End If
If Not Intersect(Target, Range("L3RoomType")) Is Nothing Then
Range("L3Dis").Value = Range("L3DisDefault").Value
End If
If Not Intersect(Target, Range("L3RoomType")) Is Nothing Then
Range("L3Pwr").Value = Range("L3PwrDefault").Value
End If
If Not Intersect(Target, Range("L3RoomType")) Is Nothing Then
Range("L3TM").Value = Range("L3TMDefault").Value
End If

Application.EnableEvents = True
End Sub

利用命名中的模式。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim IntersectRange As Range
Dim RoomNum As Long

On Error GoTo EH ' Ensure events get turned back on
Application.EnableEvents = False

For RoomNum = 1 To 3 ' or 50?
Set IntersectRange = Intersect(Target, Me.Range("L" & RoomNum & "RoomType"))
If Not IntersectRange Is Nothing Then
Me.Range("L" & RoomNum & "Dis").Value = Me.Range("L" & RoomNum & "DisDefault").Value
Me.Range("L" & RoomNum & "Pwr").Value = Me.Range("L" & RoomNum & "PwrDefault").Value
Me.Range("L" & RoomNum & "TM").Value = Me.Range("L" & RoomNum & "TMDefault").Value
End If
Next
EH:
Application.EnableEvents = True
End Sub

最新更新