Excel VBA: оптимизация функции Worksheet_Change, чтобы избежать «Недостаточно системных ресурсов для полного отображения» - PullRequest
Новая
       2

Excel VBA: оптимизация функции Worksheet_Change, чтобы избежать «Недостаточно системных ресурсов для полного отображения»

0 голосов
/ 12 июня 2019

Сначала я должен сказать, что я новичок в VBA. Я понимаю основы VBA, и я уже сделал несколько небольших проектов, но большинство из них были связаны с поиском в Google.

В текущем выпуске я не смог найти полезных советов в Интернете. Может быть, это потому, что я создал код самостоятельно. Но убедитесь сами ...

Я пытаюсь создать таблицу с данными клиента. Таблица содержит номер клиента в column "I", который добавляется вручную. Теперь таблица должна автоматически подбирать другие данные клиента, такие как место жительства, возраст и т. Д., На основе номера клиента из статической базы данных, которая находится на другой вкладке. Тем не менее, я хочу иметь возможность вручную перезаписать ячейки в моей таблице, которые содержат данные клиента из базы данных. Но когда я удаляю свои записи вручную, исходные данные из базы данных должны появиться снова.

С кодом ниже я смог это сделать. Когда ячейка пуста, код добавляет formula в ячейку, которая собирает данные из базы данных. Тем не менее, я могу переписать formula вручную. Когда я удаляю свою ручную запись, и ячейка снова становится пустой, formula появляется снова и забирает данные из базы данных. Но у меня есть две проблемы с кодом ниже:

  1. Код кажется слишком «тяжелым». Например, когда я удаляю строки, я получаю сообщение об ошибке "Not enough system resource to display completely", которое останавливает весь файл Excel.

  2. Когда я добавляю новые номера клиентов в column "I", код не получает данные из базы данных автоматически. Мне нужно вызвать Worksheet_Change для каждой отдельной ячейки, выбрав ячейку и нажав Delete

Итак, я ищу способ упростить мой код, чтобы:

  1. сообщение об ошибке больше не появляется при удалении строк;

  2. когда я добавляю новый номер клиента в column "I", другие ячейки в той же строке должны мгновенно получать другие данные клиента из базы данных.

Я уже попробовал следующее, но безуспешно:

  1. Для удаления строк я создал код, который делает это автоматически, и добавил Application.EnableEvents = False в начале кода и Application.EnableEvents = True в конце с намерением остановить Worksheet_Change, пока строки обрабатываются удалил, но это не сработало, и я все еще получил ошибку.

  2. Чтобы вызвать Worksheet_Change, я использовал следующий код Application.Run "Sheet3.Worksheet_Change", Range("A1:Z5000") и присвоил его кнопке, но он не работал.

Итак, вот существующий код (обратите внимание, что код выглядит длиннее, чем он есть. Код для каждого столбца одинаков, отличается только formulas, который вводится в ячейки): 

Private Sub Worksheet_Change(ByVal Target As Range)

'Code for column B
Dim AffectedRange As Range
Set AffectedRange = Intersect(Target, Me.Range("B2:B" & Me.Rows.Count))

If Not AffectedRange Is Nothing Then
    Dim iCell As Range
    For Each iCell In AffectedRange.Cells

            If iCell.Value = vbNullString Then
            iCell.Formula = "=IFERROR(IF($I" & iCell.Row & "="""","""",VLOOKUP($I" & iCell.Row & ",'Raw Data'!$A$1:$AH$5000,4,FALSE)),""N/A"")"
        End If
    Next iCell
End If

'Code for column D
Dim AffectedRange1 As Range
Set AffectedRange1 = Intersect(Target, Me.Range("D2:D" & Me.Rows.Count))

If Not AffectedRange1 Is Nothing Then
    Dim iCell1 As Range
    For Each iCell1 In AffectedRange1.Cells

            If iCell1.Value = vbNullString Then
            iCell1.Formula = "=IFERROR(IF($I" & iCell1.Row & "="""","""",IF(VLOOKUP($I" & iCell1.Row & ",'Raw Data'!$A$1:$AH$5000,9,FALSE)=0,""N/A"",VLOOKUP($I" & iCell1.Row & ", 'Raw Data'!$A$1:$AH$5000,9,FALSE))),""N/A"")"
        End If
    Next iCell1
End If

'Code for column E
Dim AffectedRange2 As Range
Set AffectedRange2 = Intersect(Target, Me.Range("E2:E" & Me.Rows.Count))

If Not AffectedRange2 Is Nothing Then
    Dim iCell2 As Range
    For Each iCell2 In AffectedRange2.Cells

            If iCell2.Value = vbNullString Then
            iCell2.Formula = "=IFERROR(IF($I" & iCell2.Row & "="""","""",IF(VLOOKUP($I" & iCell2.Row & ",'Raw Data'!$A$1:$AH$5000,10,FALSE)=0,""N/A"",VLOOKUP($I" & iCell2.Row & ", 'Raw Data'!$A$1:$AH$5000,10,FALSE))),""N/A"")"
        End If
    Next iCell2
End If

'Code for column C
Dim AffectedRange4 As Range
Set AffectedRange4 = Intersect(Target, Me.Range("C2:C" & Me.Rows.Count))

If Not AffectedRange4 Is Nothing Then
    Dim iCell4 As Range
    For Each iCell4 In AffectedRange4.Cells

            If iCell4.Value = vbNullString Then
            iCell4.Formula = "=IFERROR(IF($I" & iCell4.Row & "="""","""",IF(VLOOKUP($I" & iCell4.Row & ",'Raw Data'!A$1:$AH$5000,22,FALSE)=0,""N/A"",IF(VLOOKUP($I" & iCell4.Row & ",'Raw Data'!A$1:$AH$5000,22,FALSE)<0.49999,""Prio 3"",IF(AND(VLOOKUP($I" & iCell4.Row & ",'Raw Data'!A$1:$AH$5000,22,FALSE)>0.49999,VLOOKUP($I" & iCell4.Row & ",'Raw Data'!A$1:$AH$5000,22,FALSE)<0.79999),""Prio 2"",IF(VLOOKUP($I" & iCell4.Row & ",'Raw Data'!A$1:$AH$5000,22,FALSE)>0.79999,""Prio 1"",""N/A""))))),""N/A"")"
        End If
    Next iCell4
End If

'Code for column H
Dim AffectedRange5 As Range
Set AffectedRange5 = Intersect(Target, Me.Range("H2:H" & Me.Rows.Count))

If Not AffectedRange5 Is Nothing Then
    Dim iCell5 As Range
    For Each iCell5 In AffectedRange5.Cells

            If iCell5.Value = vbNullString Then
            iCell5.Formula = "=IFERROR(IF($I" & iCell5.Row & "="""","""",IF(VLOOKUP($I" & iCell5.Row & ",'Raw Data'!$A$1:$AH$5000,11,FALSE)=0,""N/A"",VLOOKUP($I" & iCell5.Row & ", 'Raw Data'!$A$1:$AH$5000,11,FALSE))),""N/A"")"
        End If
    Next iCell5
End If

'Code for column F
Dim AffectedRange6 As Range
Set AffectedRange6 = Intersect(Target, Me.Range("F2:F" & Me.Rows.Count))

If Not AffectedRange6 Is Nothing Then
    Dim iCell6 As Range
    For Each iCell6 In AffectedRange6.Cells

            If iCell6.Value = vbNullString Then
            iCell6.Formula = "=IFERROR(IF($I" & iCell6.Row & "="""","""",(IF(OR($D" & iCell6.Row & "=""N/A"",$D" & iCell6.Row & "=""""),""N/A"",IF(AND($H" & iCell6.Row & "=""Espagne"",LEN($D" & iCell6.Row & ")=5),VLOOKUP(LEFT($D" & iCell6.Row & ",2),Regionslist!$A$1:$B$52,2,FALSE),IF(AND($H" & iCell6.Row & "=""Espagne"",LEN($D" & iCell6.Row & ")=4),VLOOKUP(""0""&LEFT($D" & iCell6.Row & ",1),Regionslist!$A$1:$B$52,2,FALSE),$H" & iCell6.Row & "))))),$H" & iCell6.Row & ")"
        End If
    Next iCell6
End If

'Code for column G
Dim AffectedRange7 As Range
Set AffectedRange7 = Intersect(Target, Me.Range("G2:G" & Me.Rows.Count))

If Not AffectedRange7 Is Nothing Then
    Dim iCell7 As Range
    For Each iCell7 In AffectedRange7.Cells

            If iCell7.Value = vbNullString Then
            iCell7.Formula = "=IFERROR(IF($I" & iCell7.Row & "="""","""",VLOOKUP($F" & iCell7.Row & ",Regionslist!$B$1:$C$52,2,FALSE)),$F" & iCell7.Row & ")"
        End If
    Next iCell7
End If

'Code for column J
Dim AffectedRange8 As Range
Set AffectedRange8 = Intersect(Target, Me.Range("J2:J" & Me.Rows.Count))

If Not AffectedRange8 Is Nothing Then
    Dim iCell8 As Range
    For Each iCell8 In AffectedRange8.Cells

            If iCell8.Value = vbNullString Then
            iCell8.Formula = "=IFERROR(IF($I" & iCell8.Row & "="""","""",VLOOKUP($I" & iCell8.Row & ",'Raw Data'!$A$1:$AH$5000,2,FALSE)),""N/A"")"
        End If
    Next iCell8
End If

'Code for column K
Dim AffectedRange9 As Range
Set AffectedRange9 = Intersect(Target, Me.Range("K2:K" & Me.Rows.Count))

If Not AffectedRange9 Is Nothing Then
    Dim iCell9 As Range
    For Each iCell9 In AffectedRange9.Cells

            If iCell9.Value = vbNullString Then
            iCell9.Formula = "=IFERROR(IF($I" & iCell9.Row & "="""","""",IF(SUBSTITUTE(VLOOKUP($I" & iCell9.Row & ",'Raw Data'!$A$1:$AH$5000,13,FALSE),"","","""")<>"""",SUBSTITUTE(VLOOKUP($I" & iCell9.Row & ",'Raw Data'!$A$1:$AH$5000,13,FALSE),"","",""""),""N/A"")),""N/A"")"
        End If
    Next iCell9
End If

'Code for column L
Dim AffectedRange10 As Range
Set AffectedRange10 = Intersect(Target, Me.Range("L2:L" & Me.Rows.Count))

If Not AffectedRange10 Is Nothing Then
    Dim iCell10 As Range
    For Each iCell10 In AffectedRange10.Cells

            If iCell10.Value = vbNullString Then
            iCell10.Formula = "=IFERROR(IF($I" & iCell10.Row & "="""","""",SUBSTITUTE(VLOOKUP($I" & iCell10.Row & ",'Raw Data'!$A$1:$AH$5000,20,FALSE),"","","""")),""N/A"")"
        End If
    Next iCell10
End If

'Code for column M
Dim AffectedRange11 As Range
Set AffectedRange11 = Intersect(Target, Me.Range("M2:M" & Me.Rows.Count))

If Not AffectedRange11 Is Nothing Then
    Dim iCell11 As Range
    For Each iCell11 In AffectedRange11.Cells

            If iCell11.Value = vbNullString Then
            iCell11.Formula = "=IFERROR(IF($I" & iCell11.Row & "="""","""",VLOOKUP($I" & iCell11.Row & ",'Raw Data'!$A$1:$AH$5000,22,FALSE)),""N/A"")"
        End If
    Next iCell11
End If

'Code for column N
Dim AffectedRange12 As Range
Set AffectedRange12 = Intersect(Target, Me.Range("N2:N" & Me.Rows.Count))

If Not AffectedRange12 Is Nothing Then
    Dim iCell12 As Range
    For Each iCell12 In AffectedRange12.Cells

            If iCell12.Value = vbNullString Then
            iCell12.Formula = "=IFERROR(IF($I" & iCell12.Row & "="""","""",""1.""&VLOOKUP($I" & iCell12.Row & ",'Raw Data'!$A$1:$AH$5000,21,FALSE)),""N/A"")"
        End If
    Next iCell12
End If

'Code for column W
Dim AffectedRange13 As Range
Set AffectedRange13 = Intersect(Target, Me.Range("W2:W" & Me.Rows.Count))

If Not AffectedRange13 Is Nothing Then
    Dim iCell13 As Range
    For Each iCell13 In AffectedRange13.Cells

            If iCell13.Value = vbNullString Then
            iCell13.Formula = "=IF($I" & iCell13.Row & "="""","""",IFERROR(IF(VLOOKUP($I" & iCell13.Row & ",'Raw Data'!$A$1:$AH$5000,1,FALSE)=$I" & iCell13.Row & ",""yes"",""no""),""no""))"
        End If
    Next iCell13
End If
End sub

Заранее большое спасибо за любые советы и помощь!

С наилучшими пожеланиями, Оливер

1 Ответ

0 голосов
/ 12 июня 2019

Ваш код не проверяет изменения в столбце I, поэтому вы можете добавить блок для этого 

'Code for column B
Dim AffectedRange As Range
Set AffectedRange = Intersect(Target, Me.Range("I2:I" & Me.Rows.Count))

If Not AffectedRange Is Nothing Then
    Dim iCell As Range
    For Each iCell In AffectedRange.Cells
        Application.EnableEvents=false
        'Note the Range is *relative* to EntireRow
        iCell.EntireRow.range("B1:H1,J1:M1").value = 1 'set an initial value
        Application.EnableEvents=True
        'Then trigger a change to set the formulas
        iCell.EntireRow.range("B1:H1,J1:M1").ClearContents
    Next iCell
End I
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...