Excel zoekscherm

[Rob Storm]

Hallo Wigi,

Ik heb nog een kleine wijziging aan moeten brengen en probeer de bijbehorende problemen op te lossen maar dat lukt mij niet.

Ik heb (zie bijgevoegd excelblad) een kolom tussen gevoegd genaamd "tekstuitbreiding" wat er voor zorgt dat de prijzen niet meer worden weergegeven, ik ben er al achter dat als ik de resize ipv 3 op 4 zet dit wel gebeurd. Maar als ik eerst op omschrijving iets zoek en daarna op artikelnummer dan blijven de prijzen van de vorige zoekopdracht staan. (behalve dan van het artikelnummer wat is opgezocht)

Zou je me nog een keer uit de brand willen helpen?

Groetjes
Rob

 

[Wigi]

Hier is het:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range, rngToDo As Range, firstAddress As String
    If Target.Count > 1 Then Exit Sub
    Application.ScreenUpdating = False
    
    If Target.Address = "$C$2" Then
        Range("A7", Range("D" & Rows.Count).End(xlUp).Offset(1)).ClearContents
        Set rngToDo = Sheets("Prijslijst 2006").Range("A3", Sheets("Prijslijst 2006").Range("A3").End(xlDown))
        Set c = rngToDo.Find(Target, LookIn:=xlValues, lookat:=xlPart)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                c.Resize(, 4).Copy
                Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                Set c = rngToDo.FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
        Application.EnableEvents = False
        Range("C2").ClearContents
        Application.EnableEvents = True
    
    ElseIf Target.Address = "$C$3" Then
        Range("A7", Range("D" & Rows.Count).End(xlUp).Offset(1)).ClearContents
        Set rngToDo = Sheets("Prijslijst 2006").Range("B2", Sheets("Prijslijst 2006").Range("B2").End(xlDown))
        Set c = rngToDo.Find(Target, LookIn:=xlValues, lookat:=xlPart)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                c.Offset(, -1).Resize(, 4).Copy
                Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                Set c = rngToDo.FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
        Application.EnableEvents = False
        Range("C3").ClearContents
        Application.EnableEvents = True
    End If
    Target.Select
    Application.ScreenUpdating = True
End Sub

Je moest 2 wijzigingen doen:

- Resize( ,3) naar 4 brengen.
- het wissen van cellen is via .ClearContents. Daar moet je tot kolom D zetten en niet C.

Wigi

 

[Wigi]

Ik realiseer me nu dat een Autofilter handiger is. Als ik in het weekend tijd heb schrijf ik de code daarvoor.

Je huidige code werkt overigens zeer goed, moet je niets aan vervangen.

 

[Rob Storm]

Ik realiseer me nu dat een Autofilter handiger is. Als ik in het weekend tijd heb schrijf ik de code daarvoor.

Je huidige code werkt overigens zeer goed, moet je niets aan vervangen.

Werkt prima! tot zover bedankt! ben erg benieuwd naar het autofilter, ik wacht af.

Vr.groeten
Rob

 

[kabus]

Klopt.



Hetgeen jij vroeg was redelijk "straightforward". Er zaten geen adders onder het gras of moeilijke programmeertechnieken.

Oefening baart kunst...

Hoi Wigi,

Is het bijvoorbeed ook mogelijk om 20 van die blauwe vakjes naast elkaar te zetten en dan te laten zoeken naar de text die je in die blauwe vakjes getypt hebt. En deze onder elkaar te laten weergeven. ik ben de hele avond ermee bezig geweest kom er niet uit. Misschien dat jij of iemand anders mij hierbij kan helpen.

Alvast bedankt