Снижение производительности в цикл и заполнение недостающих данных


Я написал некоторый код, который зацикливается на конкретных данных, а затем заполняет недостающие ячейки в другой лист. Код прекрасно работает, но это занимает слишком много времени, чтобы заполнить недостающие ячейки (значения).

То, что я пытался сделать, это проверить, если ячейка B является пустым или нет , то я создал 2 переменные :

  • x для activesheet ценности, которые должны быть заполнены и

  • y по таблице 1 (источник) и сравнивать пока x матч y взять значение перед конкретными данными.

Код, который я придумал:

  Sub TraiterNoms()
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Dim i As Variant
  Dim CompareRange As Variant
  Dim x As Variant
  Dim y As Variant
  Dim derlignE As Variant
  Dim derlignC As Variant


  derlignE = Range("A" & Rows.Count).End(xlUp).Row
  derlignC = Sheets("Feuil1").Range("B" & Rows.Count).End(xlUp).Row
  Set CompareRange = Sheets("Feuil1").Range("A:A").resize(derlignC, 1)

   For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
    If Range("B" & i) = "" Then
      For Each x In Range("A:A").resize(derlignE, 1)
         For Each y In CompareRange
         If x = y Then x.Offset(0, 1) = y.Offset(0, 1)
        Next y
       Next x
      End If
    Next i
 Application.ScreenUpdating = True
 Application.DisplayAlerts = True
End Sub

Я чувствую, что я мог бы улучшить этот код, чтобы сделать его более свободно. Это было бы слишком сложными?

Что можно сказать про этот код?



791
4
задан 23 февраля 2018 в 07:02 Источник Поделиться
Комментарии
4 ответа

Общие Замечания

Примечание: Feuil зовут этого Excel версии для листа.

Какой код ФП является назначение даты последнего вхождения каждого ID в Feuil1 с совпадающими идентификаторами на Feuil2. Я предполагаю, что ОП на самом деле заинтересован в последних данных, поскольку данные отсортированы по возрастанию данных.

Кажется странным, что есть несколько вхождений идентификаторов на Feuil2. Я предполагаю, что это потому, что ОП до сих пор испытания.

ОП заявил, что он хочет "проверить, если ячейка B является пустым или нет". ОП это нужно, чтобы сохранить последнего вхождения идентификатора от перезаписи. Я справиться с этим, сохранив последняя дата, связанная с ID в поиск в словаре.

Ни один из списков заголовков. Если нет веских причин для этого, добавлять заголовки к вашим спискам.

Производительности

Коллекции идеи для подстановки значений, связанных с идентификаторами в списке. Значения хранятся в виде пар ключ/значение. Существует много видов коллекции, но словари сценариев являются самым простым в использовании. Я приведу пример использования словаря сценариев и SortList в моей ниже код.

Работа с данными в массиве гораздо эффективнее, чем работать с диапазоном. Вы получите небольшой прирост производительности при чтении данных из массива и огромный толчок к написанию данных в одной операции, используя массив. Всегда помните, что чтение данных дешевую работу и записи данных относительно дорого в сравнении.

Ссылка: VBA для Excel введение часть 25 - массивы

В моем коде ниже я не удосужился выключить Application.ScreenUpdating. Потому, что я использую поиск, и главное писать данные в одну операцию из массива на лист, что быстро.

Пример 1: Словарь - Идентификаторы Совпадают

В этом примере я хранить последняя дата, связанная с идентификатором, как пары ключ/значение в словаре. Затем я создаю массив data2A хранить идентификаторы в матче и data2B для хранения датам. Наконец-то я пишу датам data2B в Feuil2 столбце B.

Sub TraiterNoms1()
Dim data1 As Variant, data2A As Variant, data2B As Variant
Dim x As Long
Dim dic As Object, Source As Range
Set dic = CreateObject("Scripting.Dictionary")

With Worksheets("Feuil1")
data1 = .Range("A1:G1", .Range("B" & Rows.Count).End(xlUp))
'Add the latest date with the IDs on Sheet1 to the Dictionary
For x = 1 To UBound(data1)
key = data1(x, 1)
If dic.Exists(key) Then
If dic(key) < data1(x, 7) Then dic(key) = data1(x, 7)
Else
dic.Add key, data1(x, 7)
End If
Next
End With

With Worksheets("Feuil2")
Set Source = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
data2A = Source.Value

ReDim data2B(1 To UBound(data2A), 1 To 1)
For x = 1 To UBound(data2A)
key = data2A(x, 1)
data2B(x, 1) = dic(key)
Next

Source.Offset(0, 1).Value = data2B

End With
End Sub

Пример 2: словарь - написать уникальные идентификаторы и соответствующие значения Feuil2

Sub TraiterNoms2()
Dim data1 As Variant
Dim x As Long
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")

With Worksheets("Feuil1")
data1 = .Range("A1:G1", .Range("B" & Rows.Count).End(xlUp))
'Add the latest date with the IDs on Sheet1 to the Dictionary
For x = 1 To UBound(data1)
key = data1(x, 1)
If dic.Exists(key) Then
If dic(key) < data1(x, 7) Then dic(key) = data1(x, 7)
Else
dic.Add key, data1(x, 7)
End If
Next
End With

With Worksheets("Feuil2")
.Columns("A:B").ClearContents
.Range("A1:B1").Value = Array("Items", "Latest Date")
.Range("A2").Resize(dic.Count).Value = Application.Transpose(dic.Keys)
.Range("B2").Resize(dic.Count).Value = Application.Transpose(dic.Items)
End With
End Sub

Пример 3: объект sortedlist - написать отсортированный уникальные идентификаторы и соответствующие значения Feuil2

Sub TraiterNoms3()
Dim data1 As Variant, data2AB As Variant
Dim x As Long
Dim sList As Object
Set sList = CreateObject("System.Collections.SortedList")

With Worksheets("Feuil1")
data1 = .Range("A1:G1", .Range("B" & Rows.Count).End(xlUp))
'Add the latest date with the IDs on Sheet1 to the Dictionary
For x = 1 To UBound(data1)
key = data1(x, 1)
If sList.Contains(key) Then
If sList(key) < data1(x, 7) Then sList(key) = data1(x, 7)
Else
sList.Add key, data1(x, 7)
End If
Next
End With

ReDim data2AB(1 To sList.Count, 1 To 2)

For x = 0 To sList.Count - 1
key = sList.getKey(x)
data2AB(x + 1, 1) = key
data2AB(x + 1, 2) = sList(key)
Next

With Worksheets("Feuil2")
.Columns("A:B").ClearContents
.Range("A1:B1").Value = Array("Items", "Latest Date")
.Range("A2").Resize(sList.Count, 2).Value = data2AB
End With
End Sub

3
ответ дан 24 февраля 2018 в 07:02 Источник Поделиться

Похоже, что вам просто необходимо VLookup. В столбце В1 вашего активного листа вы хотите =VLookup(A1,Feuil1!$A$1:$B$4,2,0). Убедитесь в том, чтобы изменить Feuil1!$A$1:$B$4 весь ассортимент вы хотите. Если ваш диапазон является непрерывным, без пустых ячеек Control+Shift+Down с последующим удержанием Shift+RightArrow должно получить вас, что вы после.

Редактировать:
Ниже вы найдете код, который делает то, что вы пытаетесь.

Причина, почему ваш исходный код-это так медленно, у вас есть цикл For Each ... Next внутри другого цикла. Внутри это проверка каждого. и должны пройти в обоих списках. Если в первом цикле (параметру activesheet) у вас есть 10 записей, и второй цикл (Feuil1) у вас есть 15 записей вы должны сравнивать 150 раз. Если список растет, он станет медленнее и медленнее. По
рефакторинг у вас есть такой же результат, но достигается лучше и быстрее, кстати.

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

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

Public Sub TraiterNoms()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim actSheet As Worksheet
Set actSheet = ActiveSheet

Dim sourceSheet As Worksheet
Set sourceSheet = ThisWorkbook.Worksheets("Feuil1")

Dim lastFormulaRow As Long
lastFormulaRow = actSheet.Cells(Rows.Count, 1).End(xlUp).Row
Dim formulaRange As Range

On Error GoTo NoBlankCells
Set formulaRange = actSheet.Range(actSheet.Cells(1, 2), actSheet.Cells(lastFormulaRow, 2)).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0

Dim lookupFormula As String
lookupFormula = GetLookupFormula(formulaRange, sourceSheet, 2)
formulaRange.Formula = lookupFormula
Dim subArea As Range
For Each subArea In formulaRange.Areas
subArea.Value2 = subArea.Value2
Next

CleanExit:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub

NoBlankCells:
Resume CleanExit

End Sub

Private Function GetLookupFormula(ByVal depositRange As Range, ByVal lookupSheet As Worksheet, ByVal lookupColumn As Long) As String
Dim valueToMatch As String
valueToMatch = depositRange.Cells(1, 1).Offset(ColumnOffset:=-1).Address(False, False)

Dim lookupCells As String
lookupCells = GetLookupCells(lookupSheet, lookupColumn)
GetLookupFormula = "=Vlookup(" & valueToMatch & "," & lookupCells & "," & lookupColumn & ",0)"
End Function

Private Function GetLookupCells(ByVal sourceSheet As Worksheet, ByVal lookupColumn As Long) As String
Dim lastRow As Long
lastRow = sourceSheet.Cells(Rows.Count, "B").End(xlUp).Row

Dim sourceRange As Range
Set sourceRange = sourceSheet.Range(sourceSheet.Cells(1, 1), sourceSheet.Cells(lastRow, lookupColumn))

GetLookupCells = sourceRange.Parent.Name & "!" & sourceRange.Address
End Function

3
ответ дан 23 февраля 2018 в 09:02 Источник Поделиться

Ладно, глядя на книгу, я думаю , что вы делаете смотрит вверх колонны на Feuil2 на Feuil1 и если нашли, возвращая дата от Feuil1.

Это мое предположение.

Узким местом

Во-первых,


For Each y In CompareRange

Это тестирование все 7 колонок на Feuil1. Я не думаю, что вы предполагаете, что вы только хотите проверить столбец 1. Он также несет, даже если его уже нашли.

Вы также хотите, чтобы последние даты из Feuil1, я думаю, потому что это показывает по 205122681 - 11/8/2017 когда Fueil1 есть этот номер, в строках 3 и 18. Это дает ряд 18. Оба раза он ищет это число.

Так что это мое предположение, учитывая, что это фактически делает.


Производительности

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

Так что дайте себе время, что вы хотите для поиска и массив, где искать его. Массивы , как эта (она не идеальна) -

Option Explicit
Public Sub GetDates()
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Set sourceSheet = Feuil1
Set targetSheet = Sheets("feuil2")
Dim lookUpArray As Variant
Dim populateArray As Variant
Dim lastRow As Long
Dim targetRange As Range
lastRow = targetSheet.Cells(Rows.count, 1).End(xlUp).Row
Set targetRange = targetSheet.Range(Cells(1, 1), Cells(lastRow, 2))
targetRange.Select
ReDim populateArray(1 To lastRow, 1 To 2)
Dim index As Long
Dim lookupIndex As Long
For index = 1 To lastRow
populateArray(index, 1) = Cells(index, 1)
Next

lastRow = sourceSheet.Cells(Rows.count, 1).End(xlUp).Row
ReDim lookUpArray(1 To lastRow, 1 To 2)
Dim count As Long
count = 1

For index = lastRow To 1 Step -1
If Not IsInArray(sourceSheet.Cells(index, 1), lookUpArray, count) Then
lookUpArray(count, 1) = sourceSheet.Cells(index, 1)
lookUpArray(count, 2) = sourceSheet.Cells(index, 7)
count = count + 1
End If
Next
Dim lookupValue As String
For index = LBound(populateArray) To UBound(populateArray)
lookupValue = populateArray(index, 1)
For lookupIndex = 1 To count
If lookUpArray(lookupIndex, 1) = populateArray(index, 1) Then
populateArray(index, 2) = lookUpArray(lookupIndex, 2)
Exit For
End If
Next
Next

targetRange = populateArray

End Sub

Private Function IsInArray(ByVal stringToBeFound As String, ByVal sourceArray As Variant, ByVal count As Long) As Boolean
Dim i
For i = LBound(sourceArray) To count
If sourceArray(i, 1) = stringToBeFound Then
IsInArray = True
Exit Function
End If
Next i
IsInArray = False

End Function

Это занимает 0 секунд. Теперь давайте перейдем к коду.


Вмятие

Я не уверен, если отступ кода пошло наперекосяк при вставке, но это все. В Sub должны быть на первом уровне и каждый новый уровень должен быть отступ в 1 вкладке больше, чем в предыдущем уровне. Взгляните на мой пример кода.

Переменные

Ваши переменные -


  Dim i As Variant
Dim CompareRange As Variant
Dim x As Variant
Dim y As Variant
Dim derlignE As Variant
Dim derlignC As Variant

Я думаю derlignC это итератор, но я не знаю, что это перебор. В любом случае, все это вариант, когда кажется, что никто из них должны быть варианты.

Варианты объектов:


Производительности. Переменная, объявленная с типом объекта является гибким
достаточно, чтобы содержать ссылку на любой объект. Однако, когда вы вызываете
метод или свойство на такую переменную, вы всегда нести позднего связывания
(во время выполнения). В силу раннее связывание (во время компиляции) и лучше
производительность, объявить переменную с определенным именем класса, или литой
ее к определенному типу данных.

Ты лучше с видах:


  • я, derlignC, derlignE = долго

  • CompareRange, Х, Y = круг

Кроме того, называя это странным. Если отдельные буквы являются итераторами, скажи мне, что это перебор. А rowIndex или columnIndexясно. Это бесплатно, чтобы назвать их все, что вы хотите, чтобы воспользоваться этим.

И CompareRange должно быть compareRange, ВБА именования имеет первое слово в нижнем регистре, чтобы указать на порядок уровень переменной.

Я не использовать любой из ваших имен переменных.

Работа на листе

Вы работаете непосредственно на листе, изменение размера постоянно колеблется и делаем все возможное, чтобы сделать этого работать медленно. Это потому, что вы, вероятно, не знаете (пока), что это невероятно медленно.

Те же принципы, как использование .select применить - это просто замедляет код по необходимости возиться с электронными таблицами, а делать все остальное за кадром. Есть хороший вопрос на StackOverflow решение этой.


Петли

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

Кроме того, нет необходимости в цикле клетки вам не нужно, например, все колонны CompareRange.


Имена Листов

Я вижу, ты использовал свойство кодовое простыни, здорово! По некоторым причинам я не мог получить VBA, чтобы признать Feuil2 как лист, поэтому я дополнительные переменные. Вы определенно на правильном пути, кроме опоры на параметру activesheet.

Когда вы полагаетесь на параметру activesheet, вы рискуете буквально всем - вы не можете быть уверены, что будут активны. Всегда определяйте свои листы. Никогда не принимай ничего на веру, всегда четко указать ваше диапазоны е.е. Range("A1:A2") неявно по параметру activesheet пока targetSheet.Range("A1:A2") это абсолютно на целевой лист.


Рефакторинг и использование функций

Вы увидите, что я использовал одну функцию, чтобы проверить наличие значения в массиве. Можно сказать, что имя функции, что он делает, что берет эту функцию из основного кода и делает его более удобным для чтения.

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

Объяснение моего кода

Как вы можете видеть, мой код делает три вещи -
1. Создает массив, который должен быть заполнен
2. Создает массив из уникальных значений подстановки
3. Сравнивает массивы

2
ответ дан 24 февраля 2018 в 02:02 Источник Поделиться

Как уже отмечали другие авторы, здесь основными вопросами являются:


  • вы зацикливание излишне через все записи из столбца a

  • вы оба читаете и, что более важно, писать много раз

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

С моей стороны я сосредоточена на:


  • избежать зацикливания на всех

  • уменьшение пишу некоторые одноразовые заявление

поэтому я использую SpecialCells(xlCellTypeBlanks) способ для ссылки на пустые ячейки, только куда писать подстановки формулу, которая, наконец, оставить только значения

и вот результат (с дополнительные пояснения в комментариях):

Option Explicit

Sub TraiterNoms()
Dim rng As Range
With Worksheets("Feuil1") 'reference "source" sheet
Set rng = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)) 'set its column A range from row 1 down to last not empty one
End With

With Worksheets("Target") ' reference "target" sheet (change "Target" to your actual target sheet name)
With .Range("B1:B" & .Cells(.Rows.Count, 1).End(xlUp).row) 'reference its column B range from row 1 down to last not empty one
If WorksheetFunction.CountBlank(.Cells) > 0 Then ' if any blank cell in referenced range. this check to avoid error thrown by subsequent statament
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=index(Feuil1!" & rng.Offset(, 1).Address(, , xlR1C1) & ",match(RC[-1],Feuil1!" & rng.Address(, , xlR1C1) & ",0))" 'fill blank cells with a lookup (well, sort of) formula
.Value = .Value 'get rid of formulas and leave values only
End If
End With
End With
End Sub

что:


  • на 30к данных строк с 10% заготовок столбец B заняло около 2 секунд для запуска

  • на 30к данных строк с 50% заготовок столбец B около 13 секунд для запуска

2
ответ дан 24 февраля 2018 в 10:02 Источник Поделиться