bakerman

Sub Kopieren_Dagen()
'
' Kopieren_Dagen
'

'
    Dim wkDay(1 To 5) As String
    Dim m As Integer, i As Integer, dt As Date
    dt = Now()
    m = Weekday(dt, vbMonday) - 1
    For i = 1 To 5
        wkDay(i) = Format(dt - m, "yyyy_dd_mm"): m = m - 1
    Next i
    myarr = Array("", 1, 2, 3, 4)
    Blad1.Columns("F:G").EntireColumn.Hidden = True
    For i = 1 To 5
        Blad1.Range("C2") = myarr(i - 1)
        ActiveWorkbook.SaveCopyAs "D:\" & wkDay(i) & ".xlsm"
    Next
    Blad1.Columns("F:G").EntireColumn.Hidden = False
End Sub

Gooi bovenstaande er eens tegen. Deze maakt de datums van de huidige week aan, van maandag tot vrijdag.

Het werkblad is volledig beveiligd. Enkel de cellen J4, J5 en de Combobox kunnen gewijzigd worden.

Al de berekeningen gebeuren met formules en de kleurbalken en pijltje gebeurt met Voorwaardelijke Opmaak.

Momenteel staat er geen wachtwoord op de beveiliging dus wil je extra zeker zijn kan je dit alsnog doen.

Had wat tijd over dus probeer deze eens.

De berekening alsook de kleuren en pijltje gebeuren nu volledig zonder VBA.

Het formulier stuurt de ingegeven waarden naar het werkblad en haalt de resultaten terug op v/h werkblad.

Sary_Dynvisc_wb.xlsm

Maak van namen een dynamisch bereik zodat je namen kan toevoegen of verwijderen zonder dat je steeds het

bereik moet aanpassen in Namen Definiëren.

test_atr.xlsx

Met een streepje VBA is het mogelijk. Nadeel is dat je daadwerkelijk iets moet invullen in elke cel alvorens je kan verdergaan.

Private Sub Worksheet_Change(ByVal Target As Range)
 
  Dim TabOrder As String
  TabOrder = "C2,E4,G2,C4,E2,C6"
  TabOrder = "," & Replace(Replace(TabOrder & "," & Split(TabOrder, ",")(0), "$", ""), " ", "")
  If InStr(TabOrder, "," & Target.Address(0, 0) & ",") Then
    Range(Split(Split(TabOrder, "," & Target.Address(0, 0) & ",")(1), ",")(0)).Select
  End If
 
End Sub

De volgorde kan je wijzigen in TabOrder.

test volgorde niet beveiligde cellen.xlsm

Zet volgende code in de codemodule van Blad1.

Private Sub CmbATR_Change()
    With Range("Tabel1").ListObject
        Range("E7") = Application.Index(.DataBodyRange, _
                Application.Match(CmbATR.Value, .DataBodyRange.Columns(2), 0), 3)
    End With
End Sub

Heb een eenvoudig opzetje gemaakt met wat ik denk dat je bedoelt.

We zoeken steeds naar de waarde in de 1ste rij of 1ste kolom om het juiste adres te bepalen.

Het geeft je in ieder geval de functies die je nodig hebt om jouw bestand aan te passen.

Bekijk het eens en van daaruit kunnen we dan verder.

Johanvd1993.xlsx

De formule op het werkblad evalueert enkel 1 cel. Achter de schermen evalueert UitgebreidFilter de formule voor elke cel

in kolom A (of een andere kolom naargelang de opstelling van de formule). Dus naargelang hoe de formule is opgesteld wordt er gefilterd op Waar of Onwaar.

Op deze manier worden alle overeenkomende regels opgehaald en rechts in de resultaattabel geplaatst.

Alles hangt dus af op welke manier je de formule neerpent.

Deze formule is nodig om het UitgebreidFilter te laten werken.

Je mag dit gerust uit het zicht verplaatsen of de Fontkleur op Wit zetten zodat het niet opvalt.

Verplaats je het echter moet je dit wel nog even aanpassen bij Formules - Namen Beheren - Criteria.

Met een extraatje.

Het bovenste tabelletje geeft je het meest voorkomende getal per kolom met daaronder het aantal keer.

Het onderste tabelletje geeft je de meest voorkomende cijfers uit het ganse bereik met hun aantal keer daaronder.

AdvancedFilterIII.xlsm

Bij data1 in Formules - Namen Beheren verwijder de -1. Dan is je probleem opgelost.

Voor jou uiteraard hetzelfde toegewenst.

Voor de sport een nog snellere methode dan mijn vorige code (2x sneller)

AdvancedFilter.xlsm

Optie 2 lijkt mij het veiligste.

Let wel moest je mijn methode kiezen en je wil de bladnaam wijzigen dan moet je bij

Formules - Namen Beheren deze wijziging ook 2x doen bij het benoemd bereik data

Gegevens rij per rij inlezen vanuit het werkblad en verwerken is de slechtste en traagste methode in VBA.

Zeker als de dataset 4K rijen, en groeiende is.

Ik heb beide codes achter een verschillend werkblad gezet met een dataset van 5K rijen. typ in de gele cellen bv. 8 in en let op het tijdsverschil

om +/- 350 resultaatrijen op te halen.

d_ba.xlsm

Geen loops nodig.

voorbeeldbestand_wb.xlsm

=INDEX(Sheet1!$F$1:$F$5;MATCH(1;($B2=Sheet1!$B$1:$B$5)*($C2=Sheet1!$C$1:$C$5);0))

Opgelet, array formule dus bevestigen met CONTROL-SHIFT-ENTER.

Graag gedaan en bedankt voor de feedback. 👍

Aangezien de volledige padnaam in je kolom M staat.

Getest en werkend op de indeling van het laatst doorgestuurde bestand.

Sub dotch()
Dim Cell As Range, Path As String
With Sheets("Export")
    For Each Cell In .Range("M2:M" & .Cells(.Rows.Count, 13).End(xlUp).Row)
        If Cell.Value <> vbNullString Then
            If Dir(Cell.Value) <> "" Then
                With .Pictures.Insert(Cell.Value)
                    .ShapeRange.LockAspectRatio = msoFalse
                    .Left = Cell.Offset(, 1).Left: .Top = Cell.Offset(, 1).Top
                    .Width = Cell.Offset(, 1).Width: .Height = Cell.Offset(, 1).Height
                End With
            End If
        End If
    Next Cell
End With
End Sub

Heb het getest met een lege cel, bestandsnaam die aanwezig is, bestandsnaam die niet aanwezig is en verschillende extensies.

Werkt feilloos hier.

Zoals de foutmelding al aangeeft schort er iets aan je bestandsnamen. Misschien ongeldige tekens in de bestandsnaam o.i.d..

dj is je blijkbaar vergeten dus spring ik maar even in.

Volgende zou je moeten verder helpen.

Sub dotch()
Dim Cell As Range, Path As String
Path = "C:\#[Data]#\Music Collector\Images\"
With Sheets("Export")
    For Each Cell In .Range("M2:M" & .Cells(.Rows.Count, 13).End(xlUp).Row)
        If Cell.Value <> vbNullString Then
            If Dir(Path & Cell & ".*") <> "" Then
                ext = CreateObject("scripting.filesystemobject").getextensionname(Dir(Path & Cell & ".*"))
                With .Pictures.Insert(Path & Cell & "." & ext)
                    .ShapeRange.LockAspectRatio = msoFalse
                    .Left = Cell.Offset(, 1).Left: .Top = Cell.Offset(, 1).Top
                    .Width = Cell.Offset(, 1).Width: .Height = Cell.Offset(, 1).Height
                End With
            End If
        End If
    Next Cell
End With
End Sub

Sub Insert_Pict1()
    Dim lRow As Long, lLoop As Long
    Dim sShape As Shape
    Dim myarray As Variant
    With Sheets("Export")
        myarray = Application.Transpose(.Range("M2", .Range("M1048576").End(xlUp)).Value)
        If Not IsArray(myarray) Then MsgBox "Geen bestanden geselecteerd.": Exit Sub
        On Error Resume Next
        lRow = 2
        For lLoop = LBound(myarray) To UBound(myarray)
            Set sShape = .Shapes.AddPicture(myarray(lLoop), msoFalse, msoCTrue, _
                .Cells(1, 14).Left + 9, .Cells(lRow, 14).Top + 8, 80, 60)
            lRow = lRow + 1
        Next lLoop
    End With
End Sub

Wat denk je van deze?

zoeken verschillende parameters_wb.xlsx

Het kan ook met een alternatieve formule.

=$B$3 = ""

Je hebt het forum nu al 2X bezocht nadat ik gepost heb.

Is het dan echt zoveel gevraagd om even een berichtje, wat dan ook, achter te laten.

Blijkbaar nog veel te leren over forumetiquette.

Mijn interesse in jouw vraag is nu wel helemaal verdwenen. Suc6 nog met je project

112 keer bekeken en geen gegadigden, dan zal ik de debatten maar openen.

Om te filteren terwijl je typt moet je gebruik maken van een Combobox maar 25000 (of meer) comboboxen op een werkblad lijkt me overkill.

Dus met je gegevensvalidatie lijkt dit me het beste alternatief. Er is wel een stukje VBA voor nodig dus als dit een bezwaar is zit j in de problemen.

Typ het woord (of een deel) dat je zoekt in een cel in kolom B en druk op Enter (of Tab). je Validatielijst is nu gefilterd.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Columns(2)) Is Nothing Then
        If Target.Count > 1 Then Exit Sub
        If Target = vbNullString Then Exit Sub
        sn = Sheet2.Cells(1).CurrentRegion
        With CreateObject("Scripting.Dictionary")
            For j = 1 To UBound(sn)
                If sn(j, 1) Like "*" & Target.Value & "*" Then .Add sn(j, 1), ""
            Next
            Target.Validation.Delete
            Target.Validation.Add xlValidateList, , , Join(.keys, ",")
            Target.Validation.ShowError = False
        End With
    End If
End Sub

categorie selectie test.xlsm