Aanvullen ontbrekende gegevens uit bestaande data

[Bello2020]

Hallo, ik heb een vraag om hulp. Zie het voorbeeld bestand.

 

Daarin staat een kolom met "contractnummer" (A) en een kolom met "bouwjaar" (E). Mijn probleem is dat niet overal de bouwjaren bekend zijn.

Wat wil ik doen?

 

Per contractnummer kijken welk bouwjaar het meeste voorkomt en de lege cellen in de kolom "bouwjaar" welke horen bij dat contractnummer vullen met dit bouwjaar.

 

Bijvoorbeeld contract JL61. Hier zijn 3 cellen van het bouwjaar niet gevuld. Bouwjaar 2005 komt in dit contract het meeste voor. (21 keer).

Dus mogen de 3 lege cellen worden gevuld met 2005.

Deze slag moet per contract worden gemaakt.

 

Wanneer er een gelijk aantal bouwjaren voorkomt heeft het de voorkeur om het laagste bouwjaar te kiezen voor de lege cellen.

Als alles is gevuld dan is er natuurlijk niets aan de hand, als er geen enkel bouwjaar is dan mag dit met een foutmelding of als "onbekend" worden weergegeven.

 

Het voorbeeld bestand is een kleine selectie van de 10.000 regels welke ik moet doorlopen dus hulp is welkom.

 

Vullen ontbrekende bouwjaren.xlsx

[bakerman]

Deze doet wat moet maar weet niet hoe de code zich zal houden bij 10K rijen.

 

Test eens en laat maar iets weten.

 

Sub tst()
    sn = Cells(1).CurrentRegion.Offset(1).Value
    noyear = 5000
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(sn)
            If Not .exists(sn(i, 1)) Then
                .Add sn(i, 1), IIf(IsNumeric(sn(i, 5)), sn(i, 5), noyear)
            Else
                If (IsNumeric(sn(i, 5))) * (IsNumeric(.Item(sn(i, 1)))) Then
                    .Item(sn(i, 1)) = Application.Min(sn(i, 5), .Item(sn(i, 1)))
                End If
            End If
        Next
        For i = 1 To UBound(sn)
            If sn(i, 5) = vbNullString Then sn(i, 5) = IIf(.Item(sn(i, 1)) <> 5000, .Item(sn(i, 1)), "Ontbrekend")
        Next
        Cells(2, 1).Resize(UBound(sn), 5) = sn
    End With
End Sub

 

[Bello2020]

Beste Bakerman,

dank voor het meedenken en de code. Deze doet het over het hele werkblad maar ik mis helaas 1 onderdeel...

 

De lege cellen moeten gevuld worden met het bouwjaar welk per contractnummer het meeste voorkomt. Deze routine zit er volgens mij nu niet in? Voor de ontbrekende bouwjaren wordt nu altijd het "laagste" bouwjaar geselecteerd. Dit is alleen nodig bij gelijke aantallen.

 

Om te testen heb ik voor het gemak het hele bestand toegevoegd.

 

Ik probeer VBA een beetje te doorgronden als valt dat voor mij nog niet mee...  Maar hoe kan ik deze routine gebruiken wanneer de kolom met bouwjaren zich verderop in het werkblad bevindt. Zo kom ik er ook wel uit met verticaal zoeken op het unieke objectnummer maar stel ik wil deze slag overslaan?

 

 

test vullen ontbrekende bouwjaren.xlsx

[bakerman]

Probeer het eens met deze.

 

Het resultaat komt op het 2de werkblad.

 

Sub tst2()
t = Timer
    sn = Sheet1.Cells(1).CurrentRegion.Offset(1).Value
    Set dic = CreateObject("scripting.dictionary")
        For i = 1 To UBound(sn)
            If Not dic.exists(sn(i, 1)) Then dic.Add sn(i, 1), Empty
        Next
        k = 0
        For Each Key In dic.keys
            For i = 1 To UBound(sn)
                If (sn(i, 1) = Key) * (sn(i, 5) <> vbNullString) Then
                    If k = 0 Then
                        ReDim arr(0 To k)
                    Else
                        ReDim Preserve arr(0 To k)
                    End If
                    arr(k) = sn(i, 5)
                    k = k + 1
                End If
            Next
            Select Case k
                Case 0
                    dic.Item(Key) = "Ontbrekend"
                Case 1
                    dic.Item(Key) = arr(0): k = 0
                Case Is > 1
                    max = Application.Mode(arr)
                    If Not IsError(max) Then
                        dic.Item(Key) = max
                    Else
                        dic.Item(Key) = Application.Min(arr): k = 0
                    End If
                    Erase arr: k = 0
            End Select
        Next
        For i = 1 To UBound(sn)
            If sn(i, 5) = vbNullString Then sn(i, 5) = dic.Item(sn(i, 1))
        Next
        With Sheet2
            .Cells(1).CurrentRegion.Offset(1).ClearContents
            .Cells(2, 1).Resize(UBound(sn), 5) = sn
        End With
MsgBox Timer - t
End Sub

De formules op het 1ste blad zijn enkel ter controle dus die mogen weg.

Bello2020_ontbrekende bouwjaren.xlsm

[Bello2020]

De eerste indruk is dat het er goed uit ziet😃 Hier ga ik de komende dagen eens mee testen. Alvast bedankt.

[Bello2020]

Bij het testen gaat alles goed.

 

Dit lijntje mag dicht. Bedankt voor de hulp.

[kweezie wabbit]

Bedankt voor de feedback.

Dan zetten we er een op.

Succes nog