Auteur Topic: Naar een rij springen a.d.h.v. een cijfer in een cel. (gelezen 10518 keer)

AD1957 · « **Reactie #15 Gepost op:** 02 november 2021, 12:47:07 »

Je hebt het over foutmeldingen, mogen we ook weten welke.
p.s.: Bij mij werkt het bestand van Warme bakkertje gewoon.

Montagnard · « **Reactie #16 Gepost op:** 02 november 2021, 13:33:09 »

Albert , ik vind het geweldig fijn dat je ook mijn "probleem" even bekijkt maar misschien beter even afwachten , na de opmerking van 'Warme Bakkertje' i.v.m. mijn "oubollige" code

ben ik de ganse 'zoek' code aan het herschrijven..
Mvg,
Montagnard.

Warme bakkertje · « **Reactie #17 Gepost op:** 02 november 2021, 13:58:22 »

Montagnard, ik heb jouw code wat gestreamlined zodat ze voor jou nog verstaanbaar blijft.

Op deze manier kan je ze zelf ook nog verder aanpassen indien nodig.

Het geposte bestand werkt bij mij zonder foutmeldingen bij het openen, zoeken en afsluiten en opslaan.

MollyVH · « **Reactie #18 Gepost op:** 02 november 2021, 13:59:48 »

Hallo Montagnard,

Je hebt uiteraard het volste recht om zoals je het zelf noemt old skool code te gebruiken, maar er zitten toch wel een aantal overbodige zaken in. Select heb je om te beginnen al helemaal niet nodig, en bij GOTO gaan de meesten ook huiveren.
Ik ben er zeker van dat je mits enige inspanning een meer gestructureerde code ook weet te begrijpen. Zelf zou ik het nog helemaal anders doen dan onderstaande, hoor, maar ik heb er iets enigszins in jouw stijl van gemaakt, in de hoop dat je daar inspiratie in vindt.

Code: [Selecteer]

Private Sub Worksheet_Change(ByVal Target As Range)
    
If Target.Address = "$B$2" Then
    Application.EnableEvents = False
    If Target <> "" Then
        Tezoekentitel = Cells(2, 2)
        Range("b4:b13,d4:d13").ClearContents
        Startlijn = 15: positie = 4: teller = 1
        For I = Startlijn To Cells(Rows.Count, 1).End(xlUp).Row
            lijsttitel = Cells(I, 1).Value
            Rem zoeken naar overeenkomende titel(s)
            Zoekop = InStr(1, lijsttitel, Tezoekentitel, vbTextCompare)
            If Zoekop > 0 Then
                Rem er is overeenkomst
                Cells(I, 1).Copy Cells(positie, 2)
                Cells(positie, 4) = I: Rem geef de lijn aan waar de titel staat
                positie = positie + 1: teller = teller + 1
            End If
            If teller > 10 Then
                MsgBox "er zijn teveel titels met dezelfde tekst , verfijn Uw zoekopdracht", vbInformation, "Belangrijke info"
                Range("b4:b13,d4:d13").ClearContents
                Application.EnableEvents = True
                Exit Sub
            End If
        Next I
        If teller = 1 Then
            MsgBox "er zijn geen titels met deze tekst", vbInformation, "Belangrijke info"
        End If
    Else
        Range("b4:b13,d4:d13").ClearContents
    End If
    Application.EnableEvents = True
End If
    
End Sub

PS : Warme bakkertje was blijkbaar nog een minuutje eerder met een gelijkaardig plan!

Montagnard · « **Reactie #19 Gepost op:** 02 november 2021, 14:17:03 »

@Warme Bakkertje : je code werkt perfect , ik ga er mee aan de slag met hetgeen ik zelf ook aan het veranderen was.....
@MollyVH : ik heb de code gekopieerd en in kladblok gezet (die laat ik open voor als ik code nodig heb , zo hoef ik van daaruit enkel copy en paste te doen).

zoals ik al zelf schreef ben ik ook bezig , ik ga gebruik maken van beide codes of delen ervan in mijn eigen werkblad , ik laat zeker nog iets horen !

en allebei bedankt voor helpen

Mvg,

AD1957 · « **Reactie #20 Gepost op:** 02 november 2021, 15:47:00 »

Zie dat je al twee oplossingen hebt gekregen.
Omdat ik toch al bezig was hier nog eentje.
Met het toegevoegde commentaar zul je er zeker uitkomen (je bent in mijn ogen een vastbijter)

Code: [Selecteer]

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Address(0, 0) = "B2" And Not IsEmpty(Target) Then
    Application.EnableEvents = False

    Range("B4:B14,D4:D14") = ""
    
    rij_A = Range("A" & Rows.Count).End(xlUp).Row                        'laatse gevulde rij in kolom A
    rij_D = 4                                                            'rijnummer waar te beginnen in kolom D
    teller = 0
    For j = 15 To rij_A                                                   'begin te zoeken vanaf rij 15 t/m laatste rij
        If InStr(1, Range("A" & j), Range("B2"), vbTextCompare) > 0 Then
             Range("A" & j).Copy Cells(rij_D, 2)                          'kopieer de gevonden cel in kolom A naar de juiste rij in kolom D
             Cells(rij_D, 4) = Range("A" & j).Row
             rij_D = rij_D + 1
             teller = teller + 1
             
             If teller > 10 Then
                Range("B2:B14,D4:D14") = ""
                MsgBox "er zijn meer dan 10 titels gevonden, verfijn je zoekopdracht"
                Application.Goto Range("B2")
                GoTo eind
             End If
             
        End If
    Next j
    
    If MsgBox("Ben je tevreden met het aantal titels ?", vbYesNo) = vbNo Then
        Range("B2:B13,D4:D13") = ""
        Application.Goto Range("B2")
    End If
Else
    If Target.Address(0, 0) = "B2" And IsEmpty(Target) Then Range("B4:B14,D4:D14") = ""
End If


eind:
 Application.EnableEvents = True

End Sub

@Warme bakkertje,@ MollyVH,
Verbeteringen zijn van harte welkom, ik zit nml. nog steeds in een leerfase.

MollyVH · « **Reactie #21 Gepost op:** 02 november 2021, 15:53:29 »

@ AD1957,

Ik durfde eerst niet uit schrik om Montagnard helemaal uit zijn comfortzone te halen, maar omdat jij er nu specifiek om vraagt bij deze een mogelijkheid. Kan misschien nog beter, hoor, zo maar vlug uit mijn mouw geschud...

@ Montagnard,

Ter verpozing kan je deze eventueel eens proberen in een kopie van je eigen werk.

Code: [Selecteer]

Private Sub Worksheet_Change(ByVal Target As Range)
    
If Target.Address = "$B$2" Then
    Application.EnableEvents = False
    Range("b4:d13").ClearContents
    If Target <> "" Then
        tezoekentitel = Cells(2, 2)
        Range("b4:b13,d4:d13").ClearContents
        nummers = Filter(Application.Transpose(Sheets("Blad1").Range("a15:a" & Cells(Rows.Count, 1).End(xlUp).Row)), tezoekentitel, True, vbTextCompare)
        Select Case UBound(nummers)
            Case -1
                MsgBox "er zijn geen titels met deze tekst", vbInformation, "Belangrijke info"
            Case Is > 9
                MsgBox "er zijn teveel titels met dezelfde tekst , verfijn Uw zoekopdracht", vbInformation, "Belangrijke info"
            Case Else
                Range("B4").Resize(UBound(nummers) + 1) = Application.Transpose(nummers)
                Range("C4").Resize(UBound(nummers) + 1) = "in rij:"
                For I = 0 To UBound(nummers)
                    Cells(I + 4, 4) = Sheets("Blad1").Columns(1).Find(nummers(I), LookIn:=xlValues, LookAt:=xlWhole).Row
                Next I
        End Select
    End If
    Application.EnableEvents = True
End If
    
End Sub

Warme bakkertje · « **Reactie #22 Gepost op:** 02 november 2021, 16:04:42 »

Een andere methode.

Code: [Selecteer]

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B2")) Is Nothing And Range("B2").Value <> vbNullString Then
        sn = Range("A15", Range("A" & Rows.Count).End(xlUp))
        Range("b4:b13,d4:d13").ClearContents
        With CreateObject("scripting.dictionary")
            For I = 1 To UBound(sn)
                If LCase(sn(I, 1)) Like "*" & LCase(Target.Value) & "*" Then .Add sn(I, 1), I + 14
            Next
            If .Count = 0 Then MsgBox "Geen overeenkomende titel(s)gevonden !", vbInformation, "Belangrijke info": Exit Sub
            If .Count > 10 Then MsgBox "Er zijn teveel titels met """ & Target.Value & """ gevonden." & vbLf & vbLf & Space(5) & _
                                            "Verfijn Uw zoekopdracht", vbInformation, "Belangrijke info": Exit Sub
            Application.EnableEvents = False
            Cells(4, 2).Resize(.Count) = Application.Transpose(.keys)
            Cells(4, 4).Resize(.Count) = Application.Transpose(.items)
            Cells(2, 2) = vbNullString
            Application.EnableEvents = True
        End With
    End If
    Application.Goto Range("B2")
End Sub

@ MollyVH

Ook een mooie. $\o/$

AD1957 · « **Reactie #23 Gepost op:** 02 november 2021, 16:07:04 »

@MolliVH, @ Warme bakkertje
Daar moet ik even voor gaan zitten, weer iets te doen. $_/-\o_$

MollyVH · « **Reactie #24 Gepost op:** 02 november 2021, 16:19:08 »

@ allen

,

Ik zag tussendoor nog dat in de oorspronkelijke versie ook de hyperlinks werden gekopieerd naar het doelkadertje.
Van kopiëren was ik ondertussen afgestapt, dus om die hyperlinks terug op hun plaats te krijgen volstaat één extra regeltje code, nl. hier:

Code: [Selecteer]

            Case Else
                Range("B4").Resize(UBound(nummers) + 1) = Application.Transpose(nummers)
                Range("C4").Resize(UBound(nummers) + 1) = "in rij:"
                For I = 0 To UBound(nummers)
                    Cells(I + 4, 4) = Sheets("Blad1").Columns(1).Find(nummers(I), LookIn:=xlValues, LookAt:=xlWhole).Row
                    Cells(I + 4, 2).Hyperlinks.Add Anchor:=Cells(I + 4, 2), Address:=Cells(Cells(I + 4, 4), 1).Hyperlinks(1).Address      'hier dus
                Next I

Montagnard · « **Reactie #25 Gepost op:** 02 november 2021, 16:20:16 »

allemaal ne heel dikke merci $_/-\o_$ ...
mijn probleem is dat ik wel met een beetje moeite Jullie code kan begrijpen maar het zelf schrijven da kan ik totaal niet omdat ik die code ook nooit geleerd heb , heb trouwens nooit VBA geleerd , wel "basic" in de tijde van mijne Commodore 64 (vandaar mijn 'goto'

).
het weinige wat ik tot nu toe ken is zelfstudie en heel veel code van Jullie kopiëren en opslaan om dan later te kunnen gebruiken.
Mvg,
Montagnard.

ps : moesten "we" nu nog die kleine ergernis van die beveiligings melding weg krijgen dan zou ik heel kontent zijn

Montagnard · « **Reactie #26 Gepost op:** 02 november 2021, 16:32:07 »

Citaat van: MollyVH op 02 november 2021, 16:19:08

@ allen ,
Ik zag tussendoor nog dat in de oorspronkelijke versie ook de hyperlinks werden gekopieerd naar het doelkadertje.

ik heb uiteindelijk beslist om Uw code te gebruiken ( aan alle anderen : neemt het me a.u.b. niet kwalijk , ik heb Jullie code wel opgeslagen ! ).
en ik wou juist reageren betreffende die hyperlinks in het doelkader , maar Je was me te rap af , ondertussen code aangepast en alles werkt perfect !

Mvg,

JEC · « **Reactie #27 Gepost op:** 02 november 2021, 18:45:16 »

@Warme Bakkertje, de application.enableevents zou ik direct mee starten

. Je macro loopt anders meerdere malen.

Wat aanvullingen:

Code: [Selecteer]

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address(0, 0) = "B2" And Len(Target) Then
   Application.EnableEvents = False
    ar = Range("A15", Range("A" & Rows.Count).End(xlUp))
     With CreateObject("scripting.dictionary")
        For j = 1 To UBound(ar)
           If InStr(1, ar(j, 1), Target.Value, vbTextCompare) Then .Item(ar(j, 1)) = Array(ar(j, 1), "In rij:", j + 14)
        Next
        If .Count > 0 And .Count < 11 Then
          Range("B2:D13").ClearContents
          Cells(4, 2).Resize(.Count, 3) = Application.Index(.items, 0, 0)
        Else
          Application.EnableEvents = True
          If .Count = 0 Then MsgBox "Geen overeenkomende titel(s)gevonden !", vbInformation, "Belangrijke info": Exit Sub
          If .Count > 10 Then MsgBox "Te veel titels gevonden, verfijn zoekopdracht !", vbInformation, "Belangrijke info": Exit Sub
        End If
      End With
    Application.EnableEvents = True
   Application.Goto Range("B2")
  End If
End Sub

Montagnard · « **Reactie #28 Gepost op:** 03 november 2021, 15:34:31 »

voila , beetje mee "bezig" geweest...
als ik nu dus dubbelklik op een rij nummer in kolom D dan krijgt die rij de focus , m.a.w. als ik dubbels heb dan kan ik naar zo'n rij gaan en deze verwijderen.

volgende uitdaging voor mij : als ik op zo'n rij sta die ik wil verwijderen , dan wil ik het betreffende pad in de verkenner openen zodat ik deze ook daar kan verwijderen.
ik ga eerst zelf proberen , lukt het niet dan kom ik hier terug.

Mvg,
Montagnard.

MollyVH · « **Reactie #29 Gepost op:** 03 november 2021, 15:58:31 »

Dag Montagnard,

Toch al even meegeven: je kan perfect via vba een bestand verwijderen; er is dus geen enkele noodzaak om naar die map te gaan.
Let wel op: er zal je niet zomaar om bevestiging worden gevraagd zoals we dat in Windows zo gewoon zijn geworden.
Vermits je nu ook het volledige pad hebt opgenomen heb je nog enkel de instructie KILL nodig gevolgd door de bestandsnaam inclusief pad.
En niets belet jou overigens om voor het verwijderen zelf een bevestigingsvraag in je code te zetten. Succes!

Help!

Menu

Hulp bij posten

Zoeken

Recente topics

Auteur Topic: Naar een rij springen a.d.h.v. een cijfer in een cel. (gelezen 10518 keer)

AD1957

Re: Naar een rij springen a.d.h.v. een cijfer in een cel.

Montagnard

Re: Naar een rij springen a.d.h.v. een cijfer in een cel.

Warme bakkertje

Re: Naar een rij springen a.d.h.v. een cijfer in een cel.

MollyVH

Re: Naar een rij springen a.d.h.v. een cijfer in een cel.

Montagnard

Re: Naar een rij springen a.d.h.v. een cijfer in een cel.

AD1957

Re: Naar een rij springen a.d.h.v. een cijfer in een cel.

MollyVH

Re: Naar een rij springen a.d.h.v. een cijfer in een cel.

Warme bakkertje

Re: Naar een rij springen a.d.h.v. een cijfer in een cel.

AD1957

Re: Naar een rij springen a.d.h.v. een cijfer in een cel.

MollyVH

Re: Naar een rij springen a.d.h.v. een cijfer in een cel.

Montagnard

Re: Naar een rij springen a.d.h.v. een cijfer in een cel.

Montagnard

Re: Naar een rij springen a.d.h.v. een cijfer in een cel.

JEC

Re: Naar een rij springen a.d.h.v. een cijfer in een cel.

Montagnard

Re: Naar een rij springen a.d.h.v. een cijfer in een cel.

MollyVH

Re: Naar een rij springen a.d.h.v. een cijfer in een cel.