bakerman

Eentje waarbij de tabel niet nodig is.

=SUMPRODUCT(--(B9>{0;5000;10000;20000});--(B9-{0;5000;10000;20000});{0,9;-0,2;-0,15;-0,25})

@dotchiejack

Dan zal je de functie in Namen beheren moeten aanpassen aan de Nederlandse versie. (werk momenteel met XL2016 Pro US)

Probeer eerst met RC te wijzigen in RK. Lukt het dan nog niet zal je ook GET.CELL moeten wijzigen in CEL.LEZEN

Zonder VBA.

Gekleurde cellen tellen.xlsm

Deze in ThisWorkbook module.

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
    Deelnemerslijst = Sh.Name
End Sub

En deze in een Standaard module.

Public Deelnemerslijst As String

Sub Test()
    Application.Goto Sheets(Deelnemerslijst).Range("A1")
End Sub

Experimenteer hiermee maar eens wat, dan kan je het zeker aanpassen aan je noden.

Graag gedaan. Hoe valt de snelheid mee ?

Heb de code nog wat verder aangepast zodat nu eerst de oude resultaten in kolom E gewist worden.

Ook worden nu enkel de resultaten terug naar het werkblad geschreven zodat de rest van je data onaangeroerd blijft.

Sub tst()
    Dim b()
    Set dic = CreateObject("scripting.dictionary")
    sn = Cells(1).CurrentRegion.Value
    ReDim b(1 To UBound(sn) - 1, 1 To 1)
    For i = 2 To UBound(sn)
        x0 = dic.Item(sn(i, 2))
    Next
    For j = 2 To UBound(sn)
        If (sn(j, 1) = 99999) * (dic.exists(sn(j, 3))) Then b(j - 1, 1) = 1
    Next
    lRow = Range("E" & Rows.Count).End(xlUp).Row: If lRow = 1 Then lRow = 2
    Range("E2:E" & lRow).ClearContents
    Cells(2, 5).Resize(UBound(b), 1) = b
End Sub

Dan komt jouw voorbeeldbestand niet overeen met het werkelijke want draai deze maar eens.

Pas Cal.xlsm

Hoe doet deze het ?

Sub tst()
    Set dic = CreateObject("scripting.dictionary")
    sn = Cells(1).CurrentRegion.Value
    For i = 2 To UBound(sn)
        x0 = dic.Item(sn(i, 2))
    Next
    For j = 2 To UBound(sn)
        If (sn(j, 1) = 99999) * (dic.exists(sn(j, 3))) Then sn(j, 5) = 1
    Next
    Cells(1).Resize(UBound(sn), UBound(sn, 2)) = sn
End Sub

Vervang dit

Declare Function PlaySound Lib "winmm.dll" _
  Alias "PlaySoundA" (ByVal lpszName As String, _
  ByVal hModule As Long, ByVal dwFlags As Long) As Long

door dit

#If VBA7 Then
    Private Declare PtrSafe Function PlaySound Lib "winmm.dll" _
        Alias "PlaySoundA" (ByVal lpszName As String, _
        ByVal hModule As LongPtr, ByVal dwflags As Long) As Long
#Else
    Private Declare Function PlaySound Lib "winmm.dll" _
        Alias "PlaySoundA" (ByVal lpszName As String, _
        ByVal hModule As Long, ByVal dwflags As Long) As Long
#End If

en probeer nogmaals.

Sub PrintSelectionToPDF()
    Dim arTmp, shPDF()
    Dim j As Long, i As Long, naam As String
    With Sheets("Blad1")
        arTmp = .Range("C1", .Range("C" & .Rows.Count).End(xlUp)).Resize(, 2): naam = .Range("D1").Value
        ReDim shPDF(1 To Application.CountIf(.Range("D:D"), "Ja") + 1)
    End With
    shPDF(1) = "Blad2": j = 2
    For i = 2 To UBound(arTmp)
        If arTmp(i, 2) = "Ja" Then
            shPDF(j) = arTmp(i, 1): j = j + 1
        End If
    Next i
    Sheets(shPDF).Select
    ActiveSheet.ExportAsFixedFormat 0, "C:\Users\*******\" & naam
    Application.Goto Sheets("Blad1").Range("A1"), True
End Sub

Hangt er vanaf. Blijven kolommen B en E dan leeg ?

Vergeten te vermelden dat je op Blad1 het ':' moet verwijderen achter de bladnamen.

Wil je deze echter behouden moeten we de code lichtjes aanpassen.

Eentje om te testen.

Sub PrintSelectionToPDF()
    Dim arTmp, shPDF()
    Dim j As Long, i As Long, naam As String
    With Sheets("Blad1")
        arTmp = .Cells(1).CurrentRegion: naam = .Range("B1").Value
        ReDim shPDF(1 To Application.CountIf(.Range("B:B"), "Ja") + 1)
    End With
    shPDF(1) = "Blad2": j = 2
    For i = 2 To UBound(arTmp)
        If arTmp(i, 2) = "Ja" Then
            shPDF(j) = arTmp(i, 1): j = j + 1
        End If
    Next i
    Sheets(shPDF).Select
    ActiveSheet.ExportAsFixedFormat 0, "C:\Users\*******\" & naam
    Application.Goto Sheets("Blad1").Range("A1"), True
End Sub

In de veronderstelling dat P4 een datum is, de Replace funtie om problemen met het pad te vermijden.

Sub wb()
    With ActiveSheet
        .ExportAsFixedFormat 0, ThisWorkbook.Path & "\Lijsten\Storingslijst " & Replace(.Range("P4"), "/", "_"), , , , , , True
    End With
End Sub

PS: ".pdf" is niet nodig. De extensie wordt automatisch toegevoegd naargelang het gebruikte argument bij ExportAsFixedFormat.

Nu met de correcte weeknummers.

v2pchelp (1).xlsm

Quote

CE3 zou eigenlijk als waarde 52-2021

Fout !

In CE3 staat datum 26/12/2021 en dit is weeknummer 51.

@bickyvp

Ik zou me eens inlezen over hoe je correct rijen uit een tabel verwijdert.

De huidige manier is niet correct en onvolledig. Er moet minstens steeds een koprij en 1 datarij aanwezig zijn in een tabel.

Je moet dus checken hoeveel rijen er aanwezig zijn in je tabel. Als het er nog maar 1 is verwijder je de rij niet maar verwijder je enkel de

constanten zodat je eventuele formules in de tabel niet verwijdert.

Dan moet je je voorbeeldbestand in je andere vraag plaatsen.

Ik dacht dat deze vraag ging over het wegschrijven van data naar 2 worksheets ?????

Alhoewel het antwoord daarop reeds gegeven is op 20 februari door emiel. zijnde

voer de code 2X uit maar verander de sheetname in de tweede code.

Aangezien jij zoiets simpel niet klaar krijgt moet er volgens mij meer aan de hand zijn en zal je je vraag moeten verduidelijken.

=SUMPRODUCT((P3<=$P$3:$P$8)/COUNTIF($P$3:$P$8;$P$3:$P$8))

Nog eentje op de valreep.

Nadat de formule doorgetrokken is naar beneden is het gewoon een kwestie van sorteren van laag naar hoog.

Ludo.xlsx

Een idee gebaseerd op het IsoWeeknummer.

Kdb.xlsx

Aangezien er weinig animo is voor deze thread.

Function winsorize(bereik As Range, p As Integer) As Double
    r = Application.CountA(bereik): k = r * (p / 100)
    t = Fix(k): If t <> k Then t2 = Round(1 - (k - t), 2)
    If t2 = 0 Then
        For i = t + 1 To r - t
            X = X + Application.Small(bereik, i)
        Next
    Else
        For i = t + 2 To r - (t + 1)
            X = X + Application.Small(bereik, i)
        Next
        X = X + (t2 * Application.Small(bereik, t + 1)) + (t2 * Application.Small(bereik, r - t))
    End If
    winsorize = (1 / (r - (2 * k))) * X
End Function

In het werkblad invoeren als

=winsorize(A1:A10;22)

Het werkt wel maar je moet EERST werkblad factuur volledig invullen vooraleer je werkblad Herinnering selecteert.

Daarna werkt het tweewegs.

Quote

Andersom is niet noodzakelijk maar zou wel leuk zijn.

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Select Case Sh.Name
        Case "Herinnering"
            Sh.[A2:B10] = Sheets("factuur").[A2:B10].Value
        Case "factuur"
            Sh.[A2:B10] = Sheets("Herinnering").[A2:B10].Value
    End Select
End Sub

Een ideetje.

annvdb.xlsx

Dit zet je misschien op weg.

Getallen in kolom A.

Sub tst()
    For Each cl In Range("a1", Range("A" & Rows.Count).End(xlUp))
        If Left(cl, 1) = Chr(45) Then
            cl.Value = Mid(cl.Value, 2, Len(cl.Value) - 1) & Chr(45)
        End If
    Next
End Sub