bakerman

BertP,

Heb het momenteel razend druk op het werk dus antwoorden lopen vertraging op.

Mijn excuses hiervoor.

In het bestand een voorlopige aangepaste formule. Test eens of deze onder alle omstandigheden de juiste oplossing geeft.

BertP_Drukverlies berekening GAS_baII.xlsx

Als ik het goed begrijp ?

PS: Heb even formule in E23 gewijzigd omdat IFS bij mij niet werkt, maar deze kan je terug vervangen door de originele formule.

BertP_Drukverlies berekening GAS_ba.xlsx

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

Probeer het eens met deze.

Drukverlies berekening GAS_ba.xlsx

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

Kan je misschien ook uitleggen WAT er nu eigenlijk gebeurd ??????

Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.Column = 1) * (Target.Value <> vbNullString) Then
    Sheets("HNW343239").Copy , Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = "HNW" & Target.Value
End If
If Target.Column = 8 Then
Application.EnableEvents = False
    Newvalue = Target.Value
    Application.Undo
    Oldvalue = Target.Value
    If InStr(1, Oldvalue, Newvalue, vbTextCompare) > 0 Then
        Target.Value = Oldvalue: GoTo Earlyexit
    End If
    If Oldvalue = "" Then
            Target.Value = Newvalue
    Else
            Target.Value = Oldvalue & ", " & Newvalue
    End If
End If
Earlyexit:
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

    If (Target.Column = 1) * (Target.Value <> vbNullString) Then

        Sheets("HNW343239").Copy , Sheets(Sheets.Count)

        Sheets(Sheets.Count).Name = "HNW" & Target.Value
    
    End If
    
End Sub

Philiep,

Is het dan niet handiger volgende formule te gebruiken zodat je de extra cellen voor huidige datum niet nodig hebt ?

=DATUM(JAAR(NU())-$D$3;MAAND(NU())-$E$3;DAG(NU())-$F$3)

Goed gedaan. 👍

Bedankt voor de feedback.

Korte versie.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("C1")) Is Nothing Then
        Range("A2:A11").EntireRow.Hidden = Not (Application.Weekday(Target) = 3)
    End If
End Sub

Dat is de naam van je tabel die op blad documents staat.

Geef je deze naam zelf of wordt deze automatisch gegeven ?

Als deze naam automatisch meekomt zal je je tabel wel telkens moeten hernoemen naar een zelfgekozen naam gelijkaardig

aan diegene die je in de formules gebruikt.

Omdat je vraagstelling vrij summier is toch maar een poging tot ...

Bello2020_Formulier.xlsx

Ik hoop voor jou dat iemand mijn ongelijk kan bewijzen maar voor zover ik weet is dit helaas niet mogelijk.

Wijzig de waarde in B5 en de rest wordt aangevuld.

Validatie.xlsx

Toch maar even het bestandje met de formule erin.

K-rin_als functie.xlsx

=IF(F$13>$R$15;0;IF(AND(F$13>0;F$13<$R$15);$R$15-F$13;IF(F$13<0;$R$15+(F$13*-1))))

Je moet ze nog wel even vertalen.

Deze met dynamische gegevensvalidatie in kolom B zodat er geen schrijffouten kunnen voorkomen.

JTvD_invullen _namen_ba.xlsm

Deze met error-trapping in geval er voor een bepaalde shift geen namen geselecteerd zijn in werkblad Validatie.

Sub test()
    wknum = Application.InputBox("Geef het weeknummer op.", "Weeknummer", , , , , , 1)
    numcol = Cells(2, 1).CurrentRegion.Columns.Count
    If wknum <> vbNullString Then wRow = Application.Match(wknum, Columns(1), 0)
    If Not IsError(wknum) Then
        For j = 3 To numcol
            myGroup = Cells(2, j).Value
            If myGroup = "" Then Exit Sub
            x = Filter(Evaluate("transpose(if(Validatie!b2:b10000=""" & myGroup & """,Validatie!a2:a10000))"), False, 0)
            If UBound(x) = -1 Then GoTo gonext
            For WK = wRow To wRow + 28 Step 7
                Cells(WK, j).Resize(UBound(x) + 1, 1).Value = Application.Transpose(x)
            Next WK
gonext:
        Next
    End If
End Sub

Op blad Validatie zet je alle namen onder elkaar in kolom A. In kolom B zet je de shift waarin ze die week zullen werken.

Klik daarna op Blad1 op de knop en vul het gewenste weeknummer in.

Sub test()
    wknum = Application.InputBox("Geef het weeknummer op.", "Weeknummer", , , , , , 1)
    numcol = Cells(2, 1).CurrentRegion.Columns.Count
    If wknum <> vbNullString Then wRow = Application.Match(wknum, Columns(1), 0)
    If Not IsError(wknum) Then
        For j = 3 To numcol
            myGroup = Cells(2, j).Value
            If myGroup = "" Then Exit Sub
            x = Filter(Evaluate("transpose(if(Validatie!b2:b10000=""" & myGroup & """,Validatie!a2:a10000))"), False, 0)
            For WK = wRow To wRow + 28 Step 7
                Cells(WK, j).Resize(UBound(x) + 1, 1).Value = Application.Transpose(x)
            Next WK
        Next
    End If
End Sub

auto invullen namen_ba.xlsm

Bedankt voor de feedback en graag gedaan.

Je kan dit bereiken door gebruik te maken van zogenaamde 3D formules.

Ik heb een bestandje toegevoegd zodat je kan zien wat de bedoeling is.

Wil je echter een oplossing op maat van jouw bestand zal je een voorbeeld moeten posten zodat we je layout kunnen bekijken.

Excel-kenner.xlsx

Jij hebt blijkbaar wel de gewoonte om vragen onbeantwoord te laten openstaan.

Misschien kan deze ook ineens afwerken. https://www.pc-helpforum.be/topic/74639-berekenen-van-percentage/

Ik denk dat we voldoende hebben aangetoond dat dit niet mogelijk zal zijn met gewone formules. Daarom een stukje VBA.

Door de waarde in cel C2 te wijzigen worden de getallen in A5 en A10 herberekend.

controle.xlsm

Er stonden wat foutjes in de formule van emiel maar de basis heeft hij wel gelegd en deze doet wat jij verwacht.

=ALS(A1=1;'Q:\MANUFACTURING\Projecturen\X---KOST BEREKENING\info\2\[waardes 1 .xlsx]1'!$A$1;ALS(A1=2;'Q:\MANUFACTURING\Projecturen\X---KOST BEREKENING\info\2\[waardes 1 .xlsx]2'!$A$1;ALS(A1=3;'Q:\MANUFACTURING\Projecturen\X---KOST BEREKENING\info\2\[waardes 1 .xlsx]3'!$A$1;"")))

De formule uit je andere vraag werkt niet met gesloten bestanden. Je zal deze dus enkel kunnen gebruiken als je waardes-bestanden geopend zijn.

Indirect werkt niet met gesloten bestanden.