Snelle werkwijze gezocht

Status
Niet open voor verdere reacties.
K

keb

Gebruiker
Lid geworden
20 feb 2011
Berichten
133
Ik heb een database met genealogische gegevens.
De huwelijksgegevens van de echtparen zijn opgenomen op het tabblad "Paren".


Hoe kan ik met VBA snel de hele lijst (straks meer dan 100.000 items) op de ID's van een echtpaar doorlopen?
In mijn programma moet ik deze zoekactie talloze keren herhalen (ik maak een familieboom=kwartierstaat), vandaar dat snelheid gewenst is.
In het voorbeeld zoek ik IDman = 28916, IDvrouw=28917 om vervolgens de trouwdatum en trouwplaats te vinden.

For each cell in range, en filteren om kolom A en B blijkt langzaam te werken.

Wie weet in VBA een snelle zoekmethode?
 

Bijlagen

  • Paren.xlsx
    214,7 KB · Weergaven: 34
Laatst bewerkt:
Ik zie alleen een tabblad paren? Gaat het over Excel of over Website maken, Programmeren? Er staat geen code in het bestand. Al met al nogal een halfbakken vraag.:rolleyes:

Als het om Excel gaat kan je eens naar het geavanceerd filter kijken.
 
Ik zie geen tabblad 'Huwelijken' ? kan dus ook niets doorlopen.
En hoe ga je bepalen en aan het programma doorgeven welke ID's gezocht moeten worden : met een inputbox ? invullen in een zoekveld ?
 
VenA zei:
Ik zie alleen een tabblad paren? Gaat het over Excel of over Website maken, Programmeren? Er staat geen code in het bestand. Al met al nogal een halfbakken vraag.:rolleyes:

Als het om Excel gaat kan je eens naar het geavanceerd filter kijken.
Klik om te vergroten...

We zitten hier op het onderdeel “Software”/”Programmeren”, dus je kan wel nagaan dat ik het over VBA heb. Ik vind jouw reactie ongepast.

Ik heb een offline genealogisch programma met twee belangrijke tabbladen “Persoongsgevens” en “Huwelijken” (is het voorbeeld per abuis “paren” genoemd”.

Het is een volledig menugestuurd programma, inclusief muisklikken op bepaalde personen (de code ga ik hier niet uit de doeken doen!). Ik zoek alleen een snelle subroutine waarin de IDman en IDvoruw meegeef om huwelijksgegevens op te vragen (en vervolgens in een kwartierstaat te presenteren).
 
Zoiets ?
tik je beide nummers die je als voorbeeld gaf eens in, in de beide groene velden .....

Gewoon formule, komt geen VBA aan te pas. Hoeft niets te doorlopen, blijft even snel, hoe groot die lijst ook wordt ...
 

Bijlagen

  • Paren.xlsx
    202,5 KB · Weergaven: 28
Het spijt me DigiCafee: Ik moet zoeken niet op één partner, maar op de combinatie van twee partners.
Bovendien MOET is een snelle oplossing in Visual Basic for Applications hebben, dus geen Excel-oplossing.
 
VenA had dus toch weer gelijk ! Onduidelijke vraag ...
In welke application gebruik je die VBA dan wel ? Als het Excel niet is ... Beter gewoon rechttoe, rechtaan zeggen waarover het gaat en vooral betere informatie geven over de omstandigheden.
Anders kan zelfs Madame Soleil je niet helpen.
 
Het valt me op dat sommige mensen niet goed kunnen lezen.
 
Nee, Keb, we kunnen héél goed lezen, maar ... enkel wat er staat.
Probeer te begrijpen dat er héél wat meer informatie nodig is omtrent je opstelling, je vraag en je doelstelling om je adequaat te kunnen helpen ...
 
Het stond inderdaad niet in de juiste sectie.
Maar bedoel je zoiets?
Code: 
Sub Echtpaar()
    Dim Man As String
    Dim Vrouw As String
    
    Man = "28916"
    Vrouw = "28917"
    
    Set c = Range("A:A").Find(Man, , xlValues, xlWhole)
    If Not c Is Nothing Then
        If c.Offset(, 1) = Vrouw Then
            MsgBox "Gevonden op regel: " & c.Row & vbCrLf & c.Offset(, 2) & " en " & c.Offset(, 3)
        End If
    End If
End Sub
 
Laatst bewerkt:
verplaatst naar Office VBA
 
Ed Moor bedankt voor de tip over het gebruik van de instructie find!
Ik heb een aangepaste (werkende) versie moeten moeten omdat bepaalde persoen meerdere keren gehuwd kunnen zijn, en dus meer keer in de lijst mannen voorkomen.

Hier mijn code:
Code: 
Sub Echtpaar2()
'See https://www.rondebruin.nl/win/s9/win006.htm

Dim Man As Double
Dim Vrouw As Double
Dim Rng As Range
    
Man = 28916
Vrouw = 28917
    
With Sheets("Huwelijken").Range("A:A")
                           
    Set Rng = .Find(Man, , xlFormulas, xlWhole)
    'Actions if man is found
    If Not Rng Is Nothing Then FirstAddress = Rng.Address
       Do
            'mark the cell in the column to the right if "Man" is found
             Rng.Offset(0, 4).Value = "X"
            'Check if right partner is found
             If Rng.Offset(, 1) = Vrouw Then
                'Right marriage
                MsgBox "Juiste huwelijk gevonden op regel: " & Rng.Row & vbCrLf & Rng.Offset(, 2) & " en " & Rng.Offset(, 3)
                Exit Sub
                End If
                
            Set Rng = .FindNext(Rng)
            Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
    End If
    End With
End Sub
 
Laatst bewerkt door een moderator:
Dan was het dus een duwtje in de goede richting ;)

Tip:
Let voor de leesbaarheid ook op je inspringpunten:
Code: 
Sub Echtpaar2()
    [COLOR="#008000"]'See https://www.rondebruin.nl/win/s9/win006.htm[/COLOR]
    
    Dim Man As Double
    Dim Vrouw As Double
    Dim Rng As Range
        
    Man = 28916
    Vrouw = 28917
    
    With Sheets("Huwelijken").Range("A:A")
        Set Rng = .Find(Man, , xlFormulas, xlWhole)
        [COLOR="#008000"]'Actions if Man is found[/COLOR]
        If Not Rng Is Nothing Then FirstAddress = Rng.Address
        Do
            [COLOR="#008000"]'mark the cell in the column to the right if "Man" is found[/COLOR]
            Rng.Offset(, 4).Value = "X"
            [COLOR="#008000"]'Check if right partner is found[/COLOR]
            If Rng.Offset(, 1) = Vrouw Then
                'Right marriage
                MsgBox "Juiste huwelijk gevonden op regel: " & Rng.Row & vbCrLf & Rng.Offset(, 2) & " en " & Rng.Offset(, 3)
                Exit Sub
            End If
            Set Rng = .FindNext(Rng)
        Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
    End With
End Sub
 
Laatst bewerkt:
De If End If constructie in #12 klopt niet.

2 regels code is voldoende.
Code: 
Sub VenA()
  If Cells(1, 14) <> "" Then Cells(1, 14).CurrentRegion.Clear
  Cells(1).CurrentRegion.AdvancedFilter xlFilterCopy, Cells(1, 9).CurrentRegion, Range("N1")
End Sub
 

Bijlagen

  • Paren (1).xlsb
    105,1 KB · Weergaven: 35
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan