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

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.

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