Mere opslag ved hjælp af makro
I den foregående artikel beskrev jeg et simpelt opslag ved hjælp af en makro. Her er et noget mere avanceret opslag, som slet ikke kan løses alene ved hjælp af formler.
I et regneark, her Ark2 i en mappe, findes en adresseliste, her vist i uddrag:
I Ark1 skal der laves en søgefunktion, som kan søge på efternavnet og derefter hente alle informationer om alle personer, der har dette efternavn. LOPSLAG kan ikke bruges, da efternavnet ikke er entydigt, og der derfor skal hentes flere personer. Funktionen MULVLOOKUP, som findes i Jans Udvidelser, vil kunne bruges, men kræver at regnearket i så fald omstruktureres, da den kolonne, der søges i, skal stå længst til venstre, for at funktionen virker. Den har også den "skavank", at der kun skrives værdi, når der er en formel. Det vil sige at der vil skulle laves et ret stort antal formler i og med der kan være mange med samme efternavn i adresselisten.
I stedet har jeg valgt en anden løsning baseret på hændelsen Worksheet_Change, som er beskrevet under programmering. For overskuelighedens skyld, har jeg omdøbt Ark2 til "Adresser" og Ark1 til "Opslag". Opslagsarket, ser i udgangspunktet ud som vist her:
I B1 (markeret med gult) indtastes det efternavn, der ledes efter. Koden er lavet, så det er nok at skrive en del af efternavnet. "Udh" finder alle med dette navn, samt de, hvår navnet indeholder kombinationen. Fx vil en søgning på "st" finde både Steen, Stick og Dister.Der er muligt at udbygge koden, så brugeren kan vælge om der skal søges i hele efternavnet, første del af dette, sidste del af dette eller et tilfældigt sted i dette. Det kommer der nok et forslag til ved lejlighed.
Et opslag på "Udh" giver dette resultat:
Slettes indholdet af B1 eller skrives der et andet navn, slettes det, der allerede står i visningsområdet, inden de nye indsættes. Koden er konstrueret til, at kunne rumme ubegrænset mange navne (regnearkets begrænsning), men sletter pt. kun 100 navne.
Koden, der laver selve opslaget skal ligge i Opslagsarkets kodemodul.
Private Sub
Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B1")) Is Nothing Then
If IsEmpty(Target) Then
Range("b4:g104").Clear
Exit Sub
End If
Range("b4:g104").Clear
For Each c In
Sheets("Adresser").Range("c2:c100").Cells
If
UCase(c.Value) Like "*" & UCase(Target.Value) & "*" Then
Sheets(1).Range("b65000").End(xlUp).Offset(1, 0).Select
ActiveCell.Value = c.Value
For i = -2 To 4
ActiveCell.Offset(0, i + 2).Value = c.Offset(0, i).Value
Next i
End If
Next c
End If
End Sub