bakerman

Hiervoor heeft XL AutoFilter en Uitgebreid Filter ontworpen. In bijgaand voorbeeld wordt gebruik gemaakt van Uitgebreid Filter. Sub Knop1_Klikken() Sheets("Blad2").Cells(1).CurrentRegion.Offset(1).ClearContents With Sheets("Blad1") .Cells(3, 1).CurrentRegion.AdvancedFilter 2, .Range("J1:J2"), Sheets("Blad2").Range("A1:D1") End With End Sub Voorbeeld factuur ba.xlsm

Heb wat opzoekingswerk verricht en deze doet schijnbaar wat jij beoogt. Je moet nog wel Sheet1 vervangen door de werkelijke naam van je werkblad. function onOpen() { var ThisSheet = SpreadsheetApp.getActiveSpreadsheet(); var StartingTab = ThisSheet.getSheetByName("Sheet1"); // The default tab being opened var LastRow = ThisSheet.getLastRow() + 1; // One past the last row that has been entered in the spreadsheet var LastCellString = "A"+LastRow+":A"+LastRow; // The string representing the last cell to position to var LastCell = ThisSheet.getRange(LastCellString); // The internal variable of the last cell StartingTab.setActiveRange(LastCell) // Actually perform the repositioning to the last cell }

In de kolom van de actieve cel ga je met CTRL+PijlNaarBeneden naar de laatstgevulde cel. Als dus alle rijen gevuld zijn vanaf Rij 1 is dit de cel boven de eerstvolgende nieuwe regel. In VBA zou dit makkelijk op te lossen zijn met Application.Goto en Workbook_Open, maar Google Spreadsheets gebruikt echter App Script.

Zoals gevraagd met een DropDown Menu (Gegevensvalidatie) in B1 en B2. De benoemde bereiken zijn nu ook Dynamisch wat betekent dat je in de toekomst Rijen\Kolommen kan Toevoegen\Verwijderen zonder dat je steeds de formules moet wijzigen in de Name Manager. Materiaalkosten_Govert.xlsx

Probeer deze eens. Sub Rijen_Verwijderen() Application.ScreenUpdating = False lrow = Range("B" & Rows.Count).End(xlUp).Row For Each cl In Range("B2:B" & lrow) If Left(cl, 2) = 53 Then Do While (Left(cl.Offset(1), 2) <> 51) * (Left(cl.Offset(1), 2) <> 53) cl.Offset(1).EntireRow.Delete Loop End If Next Application.ScreenUpdating = True End Sub

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