Excel zoekscherm

Rob Storm · 21 nov 2006

Hallo,

Is het mogelijk om binnen excel in een blad op bepaalde woorden of nummers te zoeken en dan die gegevens in een ander blad weer te geven.

Ik heb bijgevoegd een excelbestand met daarin een zoekblad en een artikelblad.
bedoeling is dat klanten van ons in C3 bv zoeken op de naam "rail" en dan op datzelfde blad de gegevens van het blad "artikelen" erin zet. Dus het artikelnummer, de omschrijving en de prijs.

Ik hoop dat de vraag zo duidelijk is.

Hoop dat jullie er wel uit komen!

Groetjes
Rob

Wigi · 21 nov 2006

Rob

nu heb ik weinig tijd, hopelijk heb ik straks de macro voor je klaar.

Wigi

Rob Storm · 21 nov 2006

Alvast bedankt, kan er wel op wachten :thumb:

Groetjes
Rob

Wigi · 21 nov 2006

Sneller dan gepland...

:shocked:

Code:

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
    If Target.Address = "$C$3" Then
        Application.ScreenUpdating = False
        Range("A7", Range("C" & Rows.Count).End(xlUp).Offset(1)).ClearContents
        Set rngToDo = Sheets("Artikelen").Range("B2", Sheets("Artikelen").Range("B2").End(xlDown))
        Set c = rngToDo.Find(Target, LookIn:=xlValues)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                c.Offset(, -1).Resize(, 3).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
    Target.Select
    Application.ScreenUpdating = True
    End If
End Sub

Veel plezier ermee...

Wigi

marx · 21 nov 2006

Wigi zei:

Sneller dan gepland...

:shocked:

Code:

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
    If Target.Address = "$C$3" Then
        Application.ScreenUpdating = False
        Range("A7", Range("C" & Rows.Count).End(xlUp).Offset(1)).ClearContents
        Set rngToDo = Sheets("Artikelen").Range("B2", Sheets("Artikelen").Range("B2").End(xlDown))
        Set c = rngToDo.Find(Target, LookIn:=xlValues)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                c.Offset(, -1).Resize(, 3).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
    Target.Select
    Application.ScreenUpdating = True
    End If
End Sub

Veel plezier ermee...

Wigi

Rob Storm
zou jij de voledige versie kunnen toevoegen ik zou het wel willen zien

Wigi · 21 nov 2006

marx zei:
zou jij de voledige versie kunnen toevoegen ik zou het wel willen zien

Deze code is geschreven voor het bestand dat bijgevoegd werd door Rob...

Rob Storm · 21 nov 2006

Wigi zei:
Deze code is geschreven voor het bestand dat bijgevoegd werd door Rob...

Hoi Wigi,

Bedankt voor je snelle reactie, maar ik heb geen kaas gegeten van macro's, is het teveel gevraagd om het in het excel bestand te plakken (zoals het hoort, geen idee hoe het moet!!) en dat aan mij terug te sturen?

Groet
Rob

Wigi · 21 nov 2006

Klik rechts op de bladtab van het eerste blad.

Kies Code weergeven.

Plak de gegeven code in het witte scherm.

Sluit dat VBA scherm af.

Klaar!

Wigi

Rob Storm · 21 nov 2006

Wigi zei:
Klik rechts op de bladtab van het eerste blad.

Kies Code weergeven.

Plak de gegeven code in het witte scherm.

Sluit dat VBA scherm af.

Klaar!

Wigi

WWWWHHHHAAAAAAAAA Joepie geweldig! DANK JE WEL! ben ik echt blij mee! ik wist niet dat dit kon. Zou alleen nog graag ook op artikelnummer kunnen zoeken, dus kolom A. Enig idee?

Groetjes
Rob

Wigi · 21 nov 2006

Rob Storm zei:
Enig idee?

Nee

Wigi · 21 nov 2006

Wigi zei:
Nee

Grapje! Af en toe slecht karakter...

Uiteraard weet ik dat wel...

zal de code nu aanpassen.

Rob Storm · 21 nov 2006

Wigi zei:
Nee

Oke jammer, bedankt voor je moeite!

Groetjes
Rob

Wigi · 21 nov 2006

Je moet ook nog een paar kleine dingetjes doen:

- wis eerst de vorige code
- het blauwe vak C3 naar D3 kopiëren
- In C2 typ je Nr
- In D2 typ je Omschrijving

Hier is de code:

Code:

Option Explicit

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
    
    If Target.Address = "$C$3" Then
        Application.ScreenUpdating = False
        Range("A7", Range("C" & Rows.Count).End(xlUp).Offset(1)).ClearContents
        Set rngToDo = Sheets("Artikelen").Range("A2", Sheets("Artikelen").Range("A2").End(xlDown))
        Set c = rngToDo.Find(Target, LookIn:=xlValues, lookat:=xlWhole)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                c.Resize(, 3).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("D3").ClearContents
        Application.EnableEvents = True
    ElseIf Target.Address = "$D$3" Then
        Application.ScreenUpdating = False
        Range("A7", Range("C" & Rows.Count).End(xlUp).Offset(1)).ClearContents
        Set rngToDo = Sheets("Artikelen").Range("B2", Sheets("Artikelen").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(, 3).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

Wigi

Rob Storm · 21 nov 2006

Wigi zei:

Je moet ook nog een paar kleine dingetjes doen:

- wis eerst de vorige code
- het blauwe vak C3 naar D3 kopiëren
- In C2 typ je Nr
- In D2 typ je Omschrijving

Hier is de code:

Code:

Option Explicit

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
    
    If Target.Address = "$C$3" Then
        Application.ScreenUpdating = False
        Range("A7", Range("C" & Rows.Count).End(xlUp).Offset(1)).ClearContents
        Set rngToDo = Sheets("Artikelen").Range("A2", Sheets("Artikelen").Range("A2").End(xlDown))
        Set c = rngToDo.Find(Target, LookIn:=xlValues, lookat:=xlWhole)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                c.Resize(, 3).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("D3").ClearContents
        Application.EnableEvents = True
    ElseIf Target.Address = "$D$3" Then
        Application.ScreenUpdating = False
        Range("A7", Range("C" & Rows.Count).End(xlUp).Offset(1)).ClearContents
        Set rngToDo = Sheets("Artikelen").Range("B2", Sheets("Artikelen").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(, 3).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

Wigi

Ja helemaal goed, nogmaals bedankt voor je moeite! het eindresultaat mail ik nog wel naar je toe. (duurt nog wel even) Wel leuk om te zien waar je het allemaal voor toch!

Groetjes
Rob

Wigi · 21 nov 2006

Nog even zeggen dat de code veel korter kan met een nieuwe module. Misschien later doe ik dat wel eens, vandaag niet.

Rob Storm zei:
het eindresultaat mail ik nog wel naar je toe. (duurt nog wel even)

Is dit bedoeld voor Marx? Of voor mij?

Demeter · 21 nov 2006

SWEEEEEEEEEEEEEEEEEEEEEEEET :shocked:

:shocked:

Nice going Wigi,
ziet er goed uit. thanks, hier hebben we zeker wat aan.

Groet,
Ferenc

Rob Storm · 21 nov 2006

Wigi zei:
Nog even zeggen dat de code veel korter kan met een nieuwe module. Misschien later doe ik dat wel eens, vandaag niet.

Is dit bedoeld voor Marx? Of voor mij?

Voor jou!, maar Marx vroeg er inderdaad ook om dus die krijgt dan ook een mailtje.

Wigi · 21 nov 2006

Rob Storm zei:
Voor jou!, maar Marx vroeg er inderdaad ook om dus die krijgt dan ook een mailtje.

Voor mij hoeft dat niet hoor... Zulke macro's zijn dagelijkse kost...

Rob Storm · 21 nov 2006

Wigi zei:
Voor mij hoeft dat niet hoor... Zulke macro's zijn dagelijkse kost...

Oke stuur ik hem alleen naar Marx. Leuk dat je die macro's zo uit je mouw schut

Toch leuke hobby dat Excel!

Wigi · 21 nov 2006

Rob Storm zei:
Toch leuke hobby dat Excel!

Klopt.

Rob Storm zei:
Leuk dat je die macro's zo uit je mouw schut

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

Oefening baart kunst...

Excel zoekscherm

Gebruiker

Bijlagen

Inventaris

Gebruiker

Inventaris

Gebruiker

Inventaris

Gebruiker

Inventaris

Gebruiker

Inventaris

Inventaris

Gebruiker

Inventaris

Gebruiker

Inventaris

Verenigingslid

Gebruiker

Inventaris

Gebruiker

Inventaris

Wij waarderen jouw privacy