bakerman

Beperk het aantal lees- en schrijfbewerkingen van en naar het werkblad tot een minimum. Sub tst() Set dic1 = CreateObject("scripting.dictionary") Set dic2 = CreateObject("scripting.dictionary") sn = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).Resize(, 5).Value For i = 2 To UBound(sn) x0 = dic1.Item(Join(Array(sn(i, 1), sn(i, 2)), ",")) If (sn(i, 4) <> vbNullString) * (sn(i, 5) <> vbNullString) Then x0 = dic2.Item(Join(Array(sn(i, 4), sn(i, 5)), ",")) End If Next For j = 0 To dic1.Count - 1 dic1.Item(dic1.keys()(j)) = IIf(dic2.exists(dic1.keys()(j)), "Geantwoord", "Neen") Next Range("C3").Resize(dic1.Count) = Application.Transpose(dic1.items) End Sub

Vanaf XL2010 kan je gebruik maken van volgende functie gebruiken om de celkleur van VO te bepalen. Kan momenteel niet testen maar misschien kan emielDS hier wel wat mee om je verder te helpen. Function getCellColorForReals(r As Range) As Long getCellColorForReals = r.DisplayFormat.Interior.Color End Function

Je bestand is een mengeling van manueel aangebrachte kleuren en kleuren door VO. Is dit in het echte bestand ook zo ? Want kleuren aangebracht met VO worden door deze code niet herkend (daarom blijft Rij 4 ook staan)

Formula in C2 en naar beneden doortrekken. =ALS.FOUT(ZOEKEN(2^15;VIND.SPEC($E$2:$E3;$B2);$F2:$F3);"!!!")

Enkele bedenkingen. 1) Jij wil dus een bestand maken met een 100-tal tabbladen met elk dezelfde opmaak. 2) Dan een apart bestand met enkel een overzicht van alle percentages per referentienr. Mijns inziens beide een slecht idee. Daarom een vraag. Moet je op dat apart opgeslagen werkblad nog berekeningen uitvoeren of is het enkel ter referentie ? Anders raad ik je aan om elk gegenereerd werkblad op te slaan als pdf-bestand en een verzamelblad aan te maken in je template bestand met daarin een hyperlink naar dit bestand zodat je het onmiddellijk kan raadplegen indien nodig.

Kijk eens of je hiermee verder kan. Onthoud wel dat het kopieêren van de afbeeldingen alles enorm vertraagd. lv.xlsm

De resultaten kloppen mijns inziens niet. Enkele voorbeelden, Op de originele lijst heeft artikel 515508CC 12 stuks terwijl in de verzamellijst 16 wordt aangegeven. Op de originele lijst is er een artikel 535594CC dat in de verzamellijst ontbreekt. Je hebt de perfecte code in module1 staan om het aantal unieke elementen weer te geven. Als je deze code draait kom je uit op 228 terwijl de verzamellijst er slechts 206 weergeeft.

In de Bladmodule van Blad1. Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$B$10" Then For Each cl In Range("L3", Range("L" & Rows.Count).End(xlUp)) If cl.Value Like "week" & Range("C10").Value Then cl.Offset(, 1) = Range("D10").Value: Exit For End If Next End If End Sub

Bekijk deze eens. Je moet enkel de kokerdiameter invullen (in cm) en de materiaaldikte (in mm). antisliprol_ba.xlsx

Deze redenering klopt niet helemaal vrees ik aangezien je voor deze berekening ook rekening moet houden met de dikte van de kabel. In bijlage mijn bijdrage ter discussie. Ter controle. https://www.handymath.com/cgi-bin/rollen.cgi?submit=Entry lengte spiraal_ba.xlsx

Volgens mijn berekening zit er dan nog +/- 40 meter op.

Sub tst() Set sht = Blad1 sn = sht.Range("K2:K" & sht.Cells(sht.Rows.Count, 11).End(xlUp).Row) With CreateObject("scripting.dictionary") For i = 2 To UBound(sn) If sn(i, 1) <> vbNullString Then x0 = .Item(Trim(sn(i, 1))) Next y = .Count sht.Range("J2:J" & sht.Cells(sht.Rows.Count, 10).End(xlUp).Row).Interior.Color = xlNone For Each cl In sht.Range("J2:J" & sht.Cells(sht.Rows.Count, 10).End(xlUp).Row) If cl <> vbNullString Then cl.Interior.Color = IIf(.exists(Trim(cl.Value)), vbGreen, vbRed) Next End With End Sub De groene cellen zijn de bestaande nummers, de rode de nieuwe.

Application.Goto Sheets(1).Cells(27, 13), True M27:S36 in beeld in linker bovenhoek.

Het verschil zit'm hierin dat de laatste kolom bij alpha het verschil weergeeft van elke laatst gevonden kleur tot het einde van de datareeks, dus niet meer het verschil tussen 2 dezelfde kleuren.

Ik denk dat het verschil tussen 0.04 sec en 1.7 sec wel iets meer is dan 0.07 sec. 🙄 Ook geeft jouw laatste kolom enkel het verschil weer tussen de laatst gevonden kleur en het einde van de datareeks, dus niet meer het verschil tussen gelijke kleuren.

Deze maar om aan te tonen dat werken in het geheugen het verschil maakt, ook in kleinere datasets. PC-H alpha_bakerman.xlsm

Wil je toch een formule. In D2 en doortrekken naar beneden. =LINKS($C2;VIND.ALLES(" ";$C2;1)-1)

Nog een bemerking. Hoeveel plaatsnamen zijn er met kengetal 015 ? (afgaande op je voorbeeldbestand) Hoe ga je dan bepalen om welke plaats het gaat ?

Een andere mogelijkheid. Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$E$2" Then Cells(1, 10).CurrentRegion.Clear Cells(1).CurrentRegion.AdvancedFilter 2, [E1:E2], Cells(1, 10) End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("b2")) Is Nothing Then With Sheets("blad2") .Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(, 2).Value = Range("a2").Resize(, 2).Value End With End If End Sub

=SUBSTITUEREN(RK[-2];".";"")-RK[-1] @ emiel Rechter Test.xlsm klikken.

Staan je weken horizontaal. Formule in A2 en naar rechts doortrekken. =VERSCHUIVING([Map2]Blad1!$B$42;0;(KOLOM()-1)*3) Staan je weken vertikaal. Formule in B1 en naar beneden dooretrekken. =VERSCHUIVING([Map2]Blad1!$B$42;0;(RIJ()-1)*3)

Een ideetje om makkelijk alle bladnamen in een kolom te krijgen. BladNamen_Formula.xlsm

Kleine aanpassing. Sub SortBirthdays() Application.ScreenUpdating = False Dim lRow As Long With Blad1 lRow = .Cells(.Rows.Count, 1).End(xlUp).Row .Range("Z2:Z" & lRow).FormulaR1C1 = "=TEXT(RC3,""MMDD"")" .Range("A2:Z" & lRow).Sort .Range("Z2"), xlAscending, , , , , , xlNo .Range("Z2:Z" & lRow).Clear End With Application.ScreenUpdating = True End Sub en dan is dit het resultaat.

Deze sorteert op maand en dag. Je kan de dag en maandkolom zonder probleem verwijderen. Sub SortBirthdays() Application.ScreenUpdating = False Dim lRow As Long With Blad1 lRow = .Cells(.Rows.Count, 1).End(xlUp).Row .Range("Z2:Z" & lRow).FormulaR1C1 = "=TEXT(RC3,""MMDD"")" .Range("A2:Z" & lRow).Sort .Range("Z2"), xlAscending, , , , , , xlYes .Range("Z2:Z" & lRow).Clear End With Application.ScreenUpdating = True End Sub