Worksheet_Change целевой диапазон слишком медленный - PullRequest
0 голосов
/ 31 марта 2020

У меня есть макрос Excel, используемый для изменения формулы. Проблема в том, что хотя макрос работает, он делает обновление листа Excel довольно медленным. Любое предложение?

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False

    If Target.Columns.Count < Me.Columns.Count Then
        If Target.Column = 4 Then
            If Target.Row >= 49 And Target.Row <= 178 Then
                Dim r As Integer
                For r = 49 To 178
                    'AD = 30
                    Dim MatType As String
                    MatType = Cells(r, 4).Value
                    If MatType = "" Then
                        Cells(r, 30).Value = "0"
                    Else
                        MatType = LCase(MatType)
                        'Plechy
                        'Trubky
                        'Jine
                        If MatType = "pzs" Or MatType = "pzt" Or MatType = "Tahokov" Then
                            Cells(r, 30).Value = "=(I" & r & " * J" & r & "*L" & r & ") * 2/1000000"
                        ElseIf MatType = "jac" Or MatType = "jao" Or MatType = "tr" Or MatType = "u" Or MatType = "kr" Or MatType = "L" Or MatType = "op" Or MatType = "Trubky_spec" Then
                            Cells(r, 30).Value = "=(F" & r & "*I" & r & "*L" & r & ")/1000000"
                        Else
                            Cells(r, 30).Value = "0"
                        End If
                    End If
                Next
            End If
        End If
    End If

    Application.EnableEvents = True
End Sub

1 Ответ

2 голосов
/ 31 марта 2020

это будет только l oop те, которые меняются:

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo safeout
    Application.EnableEvents = False
    Dim rng As Range
    Set rng = Intersect(Range("D49:D178"), Target)

    If Not rng Is Nothing Then
        Dim rngCell As Range
        For Each rngCell In rng
            Dim r As Long
            r = rngCell.Row
            'AD = 30
            Dim MatType As String
            MatType = LCase$(rngCell.Value)                      
            'Plechy
            'Trubky
            'Jine
            Select Case MatType
                Case "pzs", "pzt", "Tahokov"
                    Cells(r, 30).Value = CDbl(Cells(r, "I")) * Cells(r, "J") * Cells(r, "L") * 2 / 1000000
                Case "jac", "jao", "tr", "u", "kr", "L", "op", "Trubky_spec"
                    Cells(r, 30).Value = CDbl(Cells(r, "I")) * Cells(r, "F") * Cells(r, "L") / 1000000
                Case Else
                    Cells(r, 30).Value = 0
            End Select
        Next
    End If
safeout:
    Application.EnableEvents = True
End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...