Slow performance in looping and filling missing data

Question

I wrote some code that loops for specific data and then fills the missing cells in another sheet. The code works perfectly but it takes too much time to fill the missing cells (values).

What I tried to do is to Test if Cell B is blank or not , then I created 2 variables :

• x for activesheet values which need to be filled and

• y for sheet 1 (source) and keep comparing until x match y to take the value in front of the specific data.

The code I came up with:

 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

I feel like I could improve this code to make it more fluent. Would that be over-complicated?

What's there to say about this code?

• Simon Forsberg: Comments are not for extended discussion; this conversation has been moved to chat.

Answer 1

General Observations

Note: Feuil is this Excel version's name for Sheet.

What the OP's code does is assign the date of the last occurence of each Id in Feuil1 to the matching IDs on Feuil2. I assume that the OP is actually interested in the latest data because the data is sorted by data ascending.

It seems odd to that there are multiple occurrences of Ids on Feuil2. I assume that this is because the OP is still testing.

The OP stated that he is wants to "Test if Cell B is blank or not". The OP needed this to keep the last occurence of the ID from being overwritten. I handle this by saving the latest date associated with an ID in the Dictionary lookup.

Neither of the lists have headers. Unless there is a compelling reason for this, add headers to your lists.

Performance

Collections are idea to lookup values associated with Ids in a list. The values are stored as Key/Value pairs. There are many kinds of Collection but Scripting Dictionaries are the easiest to use. I will provide example of using a Scripting Dictionary and a SortList in my code below.

Working with your data in an Array is far more efficient than working with a Range. You will receive a small performance boost by Reading the data from an Array and a huge boost by writing the data to the Range in one operation using an Array. Always remember that Reading data is a cheap operation and Writing data is relatively expensive in comparison.

Reference: Excel VBA Introduction Part 25 - Arrays

In my code below I do not bother to turn off Application.ScreenUpdating. Because I am using the lookups and more importantly writing the data in one operation from an Array to the worksheet is that fast.

Example 1: Dictionary - Match IDs

In this example I store the latest date associated with an ID as a Key/Value pair in a dictionary. I then create an an array data2A to store the Ids to match and data2B to store the associated dates. Finally I write the associated dates data2B to the Feuil2 Column 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

Example 2: Dictionary - Write Unique IDs and Matching Values to 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

Example 3: SortedList - Write Sorted Unique IDs and Matching Values to 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

• POLOS Tutorials: thank you for the explination but the problem here that your code is specific to deal with dates and also when for E.g there is an identical DATA in column 1 in Feuil1 it delete the repeated value and and take the related date in Feuil2 and that's not what I'm looking For :P however as you explained Scipting Dictionnaries is the easiest to reach the perfect result
• user109261: @POLOSTutorials Example 1 matches every entry. After reading your comments my code should be modified to load the data using Step -1 and use If not dic.Exists(key) Then dic.Add Key.value.
• POLOS Tutorials: do you mean something like this filedropper.com/stackoverflow if you could modify and return a link of the file :-)
• user109261: Download File. I modified the code using a slightly different technique. I use the dictionary to store the index of the last occurence of each ID. I then retrieve the index of the source array for each ID on Feuil2 and use it to fill a 2 Column array that is the written to Feuil2.
• user109261: I also added a header row to Feuil1 (of course I had to guess at the actual column names...lol). I did this to demonstrate how to use an Enumeration to return Column numbers. It is all pretty self explanatory I think that these techniques will be very useful to you in the future.

Answer 2

It looks like you just need VLookup. In column B1 of your active sheet you'll want =VLookup(A1,Feuil1!$A1ドル:$B4,2,0ドル). Make sure to edit Feuil1!$A1ドル:$B4ドル to be the entire range you want. If your range is contiguous, no empty cells, Control+Shift+Down followed by Holding Shift+RightArrow ought to get you what you're after.

Edit: Below you'll find code that does what you're attempting.

The reason why your initial code is so slow is you have a loop For Each ... Next within another loop. Inside this is checking each and every single one. and must go through the both lists. If in your first loop (ActiveSheet) you have 10 entries and your second loop (Feuil1) you have 15 entries you have to compare 150 times. If either list grows it will get slower and slower. By refactoring you have the same outcome but achieved by a better, faster, way.

Strive for code that is self documenting. What is occurring should be apparent when you read it. Minimal effort should be needed to understand what is going on.

The code below has a main Sub that sets some variables and calls on functions to provide information to complete the required task.

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

• POLOS Tutorials: I can't limit myself with a specific range everytime I wanna to loop and fill . but I didn't understand the part of Control+Shift+Down and Shift+RightArrow
• QHarr: @POLOSTutorials That finds last used row and column. You already have variables for last used row in each sheet.
• IvenBach: So you want the range to be dynamic whenever the code is run?
• POLOS Tutorials: Yes I want it to be dynamic and not only one column
• user109261: When I ran the OPs code it looked up the date (Column G) of the last occurence of the IDs on Feuil2. You code returned Column B of the first occurence.

Answer 3

All right, looking at your workbook I think what you're doing is looking up column A on Feuil2 on Feuil1 and if found, returning the date from Feuil1.

That's my assumption.

Bottleneck

First,

For Each y In CompareRange

This is testing all 7 columns on Feuil1. I don't think you intend that, you only want to test column 1. It also carries on even if it's already found.

You also want the latest date from Feuil1, I think, because that's what is showing up for 205122681 - 11/8/2017 when Fueil1 has that number on rows 3 AND 18. It's giving row 18. Both times it searches that number.

So that's my assumption, given what it is actually doing.

---

Performance

If I were to tell you only about performance, and you wanted to keep it in VBA, I'd say use arrays. I mean you could use a Dictionary, but that might be a bit of a jump from this to that.

So give yourself an array of what you want to lookup and an array of where to look it up. Arrays like this (it isn't perfect) -

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

This takes 0 seconds to run. Now let's move on to your code.

---

Indentation

I'm not sure if the indentation of the code went awry when pasted, but it's all off. The Sub should be at the first level and each new level should be indented 1 tab more than the previous level. Take a look at my code for example.

Variables

Your variables -

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

I think derlignC is an iterator, but I don't know what that is iterating. Either way, everything is a Variant when it seems like none of them need to be variants.

Variants are objects:

Performance. A variable you declare with the Object type is flexible enough to contain a reference to any object. However, when you invoke a method or property on such a variable, you always incur late binding (at run time). To force early binding (at compile time) and better performance, declare the variable with a specific class name, or cast it to the specific data type.

You're better off with Types:

• i, derlignC, derlignE = Long
• CompareRange, x, y = Range

Also, your naming is strange. If the single letters are iterators, tell me what they are iterating. A rowIndex or a columnIndex, be clear. It's free to name them anything you want, so take advantage of that.

And CompareRange should be compareRange, VBA naming has the first word lowercase to indicate a procedure level variable.

I didn't reuse any of your variable names.

Working on the sheet

You are working directly on the sheet, constantly resizing ranges and really just doing everything you can to make this run slowly. This is because you probably don't know (yet) that is this incredibly slow.

The same principles as using .select apply - it just slows the code down by needing to fiddle with the spreadsheet while doing everything else behind the scenes. There's a good question on StackOverflow addressing this.

---

Loops

When you have a bunch of loops where you loop through the same thing more than once, you probably want to look at refactoring. But in this case, since the data is static, just put it into an array and look in the array.

Also, no need to loop through cells you don't need to, e.g. all columns of CompareRange.

---

Worksheet Names

I see you used the codename property of your sheets, great! For some reason I couldn't get VBA to recognize Feuil2 as a sheet, hence my extra variables. You were definitely on the right track here, except relying on activesheet.

When you rely on activesheet, you risk literally everything - you can't be sure what will be active. Always define your sheets. Never take anything for granted, always explicitly state your ranges e.e. Range("A1:A2") is implicitly on activesheet while targetSheet.Range("A1:A2") is absolutely on the target sheet.

---

Refactoring and using functions

You'll see I used a single function to test the existence of a value in the array. You can tell by the name of the function what it's doing, which takes that function out of the main code and makes it easier to read.

You can also refactor. My code could be refactored for populating arrays. But, in the way that I wrote it, I'd need to rewrite how I know the size of the source array, so I didn't. That's just lazy of me, sorry.

Explanation of my code

As you can probably see, my code does three things - 1. Creates an array that needs to be populated 2. Creates an array of unique lookup values 3. Compares the arrays

• POLOS Tutorials: Thank you for your answer but I your code works and give me last Date but when there is for E.g this value 205122681 repeated twice in row 3 and 18 i need to pull those data in Feuil2 infront of the first 205122681 a data row 3 and the other 205122681another data in row18 and I don't to be limited to work on date I need the other column :-)
• Raystafarian: I told you what I assumed it was doing, what I saw it was doing. That's what I critiqued.
• POLOS Tutorials: Yes , as result your code is doing the same thing as my code but much more easier to understand and to manipulate :-)
• user109261: Good job. I made some notes on your code:Download Review. Your code has the advantage over mine of working on Macs. But I still prefer the simplicity and versatility of a using a Dictionary. +1 my friend

Answer 4

As already pointed out by other contributors here, the main issues are:

• you are looping unnecessarily through all record of column A

• you're both reading and, what's more important, writing a lot of times

so all answers given before provide patterns to avoid or at least limit those issues impact

On my part I concentrated on:

• avoid looping at all

• reducing writing to some one-shot statement

so I use SpecialCells(xlCellTypeBlanks) method to reference blank cells only where to write a lookup formula of which finally leave only values

and here's the outcome (with further explanations in comments):

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

which:

• on a 30k rows data with 10% of column B blanks took some 2 seconds to run

• on a 30k rows data with 50% of column B blanks took some 13 seconds to run

• POLOS Tutorials: thank you for the explanation +1 my friend but how to manage the other columns you are here only refering to one column which is B
• DisplayName: Not sure to understand you: can you be more explicit?
• POLOS Tutorials: sorry but how can I fill the other columns in my file I got more than 1 column at least 3 to loop and fill
• DisplayName: Am I wrong or you did mention only columns A and B in your question and attached code? Anyway you can easily tweak my code to account for columns C (and D and so on) also: just duplicate theWith .Range("B1:B" & .Cells(.Rows.Count, 1).End(xlUp).row)... End With block and change 1) B to C (and D and so on) 2)rng.Offset(, 1) to rng.Offset(, 2) (and 3 and so on) 3) RC[-1] to RC1. And consider marking answer as accepted if it solved your original question. Thank you
• POLOS Tutorials: the tric of my code that I mentionned A and B but when he find a match between column A in target sheet and column A in source sheet , it copy the columns C and D it depend in what Value I put in this line (derlignC, 1) and (derlignE, 1)