lastige berekening

[robertkars]

Dames en heren,

ik ben bezig met een aantal sheets, waar dezelfde berekeningen gemaakt moeten gaan worden. In de bijlage een voorbeeld.
in het bronbestand (tabblad1) staan de gegevens. In het doelbestand zoals ik het graag automatisch wil hebben ingevuld.
Doelbestand: in kolom onderbreking en locatie, komen de gegevens te staan welke kunnen variëren.
Staat er in het bronbestand in kolom J, K of L, in de betreffende rij, een "ja" dan deze in de bijbehorende kolom in doelbestand plaatsen.
Staat er in bronbestand kolom J een tijd van 15 min of korter, dan deze in de kolom doelbestand "onderbreking" plaatsen. Als die tijd tussen de 5 min en 15 min is, dan die tijd in het groen. Is die tijd onder de 5 min dan die tijd in rood.

Ik hoop van harte dat iemand de oplossing heeft.

Alvast bedanktBekijk bijlage forum vraag.xlsx

 

[wbvalk]

Met hulp middelen

heb een beetje lopen knutselen voor je.
Misschien kom je zo een eind op weg

Willem

 

[robertkars]

Dank je wel Willem, dit is een flinke opzet, erg blij mee.
Ik ga ermee stoeien, en als ik nog vragen heb, hoop ik je die te mogen stellen.

 

[wbvalk]

Graag gedaan

Hoi Robert,

als je er tevreden mee bent en geen vragen meer hebt. Vergeet dan niet de vraag als opgelost te zetten

Groet Willem.

en laat mijn bus op tijd blijven rijden

 

[robertkars]

Ik heb het handmatig gedaan, alle formules per regel aanpassen was teveel werk.
Wel bedankt Willem.
Ik heb dit volgende week weer, is er iemand die het gehele proces kan automatiseren?

 

[wbvalk]

Helaas

Hoi Robert,

Jammer dat je er niks aan hebt, alleen begrijp ik niet wat je bedoelt met de formule's per regel.Je kan de formule gewoon doortrekken naar onderen.
als je een andere indeling neemt gaat het dan nog makkelijker.

 

[cow18]

met een macrootje

 

[robertkars]

Hallo Cow18,

Bedankt voor je macro.
Waar ik nu tegen aanloop:
Ik heb met ALT-F11 VB geopend, en de module gekopieerd en in mijn eigen bestand gezet.
Het bestand is gelijk aan het bestand dat in het voorbeeld staat. Alleen kunnen de cijfers in kolom B anders zijn. De tabbladen hebben ook dezelfde naam.
Als ik nu ga naar: Beeld-Macro's-Macro's weergeven-macro starten, dan krijg ik de volgende foutmelding melding

 If Not .exists(s(0)) Then                                'naam staat nog niet in dictionary

Ik heb gekeken naar het voorbeeld bestand en mijn eigen bestand, en ik zie hier geen afwijkingen, ben ik wellicht iets vergeten?

 

[robertkars]

Hoi Robert,

Jammer dat je er niks aan hebt, alleen begrijp ik niet wat je bedoelt met de formule's per regel.Je kan de formule gewoon doortrekken naar onderen.
als je een andere indeling neemt gaat het dan nog makkelijker.

Hoi Willem, als ik de formule naar beneden sleep, wordt de tekst niet veranderd waar je naar zoekt

 

[cow18]

een extra if om te controleren of er geen lege cellen in je bronbereik staan of anders moest je dat bereik er anders met het echte adres erin zetten ipv die currentregion, mogelijks koos hij dat bereik iets te ruim en nam zo lege B-cellen mee

Sub VertalenGegevens()
    Dim sp(1 To 32)
    sn = Sheets("bron").Range("A3").CurrentRegion.Resize(, 31)       'brongegevens uitlezen
    sp1 = Sheets("bron").Range("A1").Resize(, 31)                    'brongegevens uitlezen

    With CreateObject("Scripting.Dictionary")
        .comparemode = 1
        For i = 1 To UBound(sn)
           [COLOR="#FF0000"] If Len(sn(i, 2)) Then[/COLOR]
                s = Split(sn(i, 2), "B")                             'gedeelte voor de B gebruiken als naam
                If Not .exists(s(0)) Then                            'naam staat nog niet in dictionary
                    sp(1) = sn(i, 1)                                 'volgnummer
                    sp(2) = s(0)                                     'naam
                    For j = 4 To 6: sp(j - 1) = sn(i, j): Next       'tijden
                    sp(6) = IIf(Len(sn(i, 10)), sn(i, 10), sn(i, 11))    'ja
                    s0 = ""
                    For j = 15 To UBound(sn, 2)
                        If sn(i, j) = "x" Then s0 = s0 & sp1(1, j)
                    Next
                    sp(7) = s0
                    For j = 7 To 10: sp(j + 1) = sn(i, j): Next      'tijden
                    For j = 11 To UBound(sp) - 1: sp(j) = "": Next   'rest leegmaken
                    sp(UBound(sp)) = 1                               'tellertje
                    .Add s(0), sp                                    'toevoegen aan dictionary
                Else
                    sp0 = .Item(s(0))                                'array met reeds aanwezige gegevens
                    x = sp0(UBound(sp0)) * 8                         'offset
                    If x <= 24 Then
                        For j = 4 To 6: sp0(j - 1 + x) = sn(i, j): Next    'tijden
                        sp0(6 + x) = IIf(Len(sn(i, 10)), sn(i, 10), sn(i, 11))    'ja
                        s0 = ""
                        For j = 15 To UBound(sn, 2)
                            If sn(i, j) = "x" Then
                                s0 = s0 & sp1(1, j)
                            End If
                        Next
                        sp0(7 + x) = s0
                        For j = 7 To 10: sp0(j + 1 + x) = sn(i, j): Next    'tijden
                        For j = 11 + x To UBound(sp) - 1: sp0(j) = "": Next
                        sp0(UBound(sp)) = sp0(UBound(sp)) + 1        'tellertje
                        .Item(s(0)) = sp0                            'array terugzetten in dictionary
                    End If
                End If
            End If
        Next
        Sheets("doel").Cells(11, 1).Resize(.Count, UBound(sp)) = Application.Index(.items, 0, 0)    'items wegschrijven naar werkblad
    End With
End Sub

 

[robertkars]

Hoi Cow18,

Nu doet hij het wel, echter hebben sommige 3 blokken en hij geeft er steeds maar 2 weer
Super dit, dank je wel

 

[cow18]

in je voorbeeld had nr 4 3 blokken en daar deed hij het wel.
Is er een onderscheid tussen je voorbeeld hier en je andere gegevens ?

 

[robertkars]

Nee niet dat ik zo zie. Ik kan je wel het origineel sturen, maar dat kan niet in het forum

 

[cow18]

zie PB

 

[robertkars]

ben er heel de week mee bezig geweest, vooral met het leren begrijpen van VBA.
Het lijkt erop dat het te maken heeft met de tekst in de B kolom(Tab bron).
Het gegeven 1801 wordt ingevuld, de cellen daaronder(tot 1802) zijn origineel leeg.
Voor het gemak heeft een helper daar wat ingevuld. Echter als ik dat handmatig moet doen bij het originele bestand, ben ik weken bezig.
Ik ben zoekende geweest hoe ik hier automatisch wat in kan laten vullen, echter kan ik niets vinden, of zoek ik op verkeerde parameters.

@Cow18, ik heb je wel de bestanden gestuurd, maar ik verwacht niet dat je alles gaat maken, ik zoek naar een uitleg en ga zelf wel aan de slag daarmee.