4
\$\begingroup\$

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?

\$\endgroup\$
1
  • \$\begingroup\$ Comments are not for extended discussion; this conversation has been moved to chat. \$\endgroup\$ Feb 23 '18 at 22:49
3
\$\begingroup\$

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
\$\endgroup\$
5
  • \$\begingroup\$ 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 \$\endgroup\$ Feb 24 '18 at 7:43
  • \$\begingroup\$ @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. \$\endgroup\$
    – user109261
    Feb 24 '18 at 10:55
  • \$\begingroup\$ do you mean something like this filedropper.com/stackoverflow if you could modify and return a link of the file :-) \$\endgroup\$ Feb 24 '18 at 11:18
  • \$\begingroup\$ 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. \$\endgroup\$
    – user109261
    Feb 25 '18 at 13:29
  • \$\begingroup\$ 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. \$\endgroup\$
    – user109261
    Feb 25 '18 at 13:30
3
\$\begingroup\$

It looks like you just need VLookup. In column B1 of your active sheet you'll want =VLookup(A1,Feuil1!$A$1:$B$4,2,0). Make sure to edit Feuil1!$A$1:$B$4 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
\$\endgroup\$
8
  • \$\begingroup\$ 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 \$\endgroup\$ Feb 23 '18 at 21:51
  • \$\begingroup\$ @POLOSTutorials That finds last used row and column. You already have variables for last used row in each sheet. \$\endgroup\$
    – QHarr
    Feb 23 '18 at 22:00
  • \$\begingroup\$ So you want the range to be dynamic whenever the code is run? \$\endgroup\$
    – IvenBach
    Feb 23 '18 at 22:05
  • \$\begingroup\$ Yes I want it to be dynamic and not only one column \$\endgroup\$ Feb 23 '18 at 22:06
  • \$\begingroup\$ 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. \$\endgroup\$
    – user109261
    Feb 24 '18 at 7:11
2
\$\begingroup\$

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

\$\endgroup\$
4
  • \$\begingroup\$ 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 :-) \$\endgroup\$ Feb 24 '18 at 8:00
  • 2
    \$\begingroup\$ I told you what I assumed it was doing, what I saw it was doing. That's what I critiqued. \$\endgroup\$ Feb 24 '18 at 8:04
  • \$\begingroup\$ Yes , as result your code is doing the same thing as my code but much more easier to understand and to manipulate :-) \$\endgroup\$ Feb 24 '18 at 8:08
  • 1
    \$\begingroup\$ 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 \$\endgroup\$
    – user109261
    Feb 24 '18 at 8:12
2
\$\begingroup\$

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

\$\endgroup\$
11
  • \$\begingroup\$ 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 \$\endgroup\$ Feb 24 '18 at 23:05
  • \$\begingroup\$ Not sure to understand you: can you be more explicit? \$\endgroup\$ Feb 24 '18 at 23:06
  • \$\begingroup\$ 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 \$\endgroup\$ Feb 24 '18 at 23:07
  • \$\begingroup\$ 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 \$\endgroup\$ Feb 24 '18 at 23:15
  • \$\begingroup\$ 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) \$\endgroup\$ Feb 24 '18 at 23:21

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.