11. april 2012 - 10:28Der er
11 kommentarer og 1 løsning
Søg og kombiner makro
Hej allesammen. Jeg har et problem, som jeg vil tro, man kan løse med en makro. Jeg har et ark med 4 kolonner men 5000 rækker. I den første kolonne er der et registreringsnummer (fx 12345), i den 2. kolonne er der et navn, i den 3. en mailadresse og i den 4. står der enten WM eller PM (står for WorkMail og PrivateMail). Jeg har brug for en makro, som kan slå registreringsnummeret op og så tjekke om der er en WM tilgængelig og så give mig den tilsvarende mail som output. Hvis WM ikke er tilgængelig (dvs. der er en blank celle ud for WM) skal jeg have PM-adressen som output, og hvis ingen af dem er tilgængelige, skal der være en fejlmeddelelse. Et eksempel på udseende af arket er således:
12345 Max Power maxpower@maxpower.com PM 12345 Max Power atwork@mail.com WM 54321 Sarah Williams sarah@mail.com PM 54321 Sarah Williams WM
Jeg kan overhovedet ikke finde ud af det, så en løsning der virker giver 100 point :) Jeg bruger Excel 2007.
Jeg ville gerne at der kom en Inputbox (er det ikke sådan det hedder?) hvor der bliver spurgt efter reg. nr., som man indtaster og trykker ok. Derefter vil jeg også gerne have resultatet i en box hvor man trykker ok. Det ville være det optimale!
Rem Der forventes overskrift i række 1 Rem VBA-koden anbringes under relevante ark Rem Ingangsættes m/Alt+F8 fra Ark Rem ======================================= Dim række As Long, sidsteRække As Long Public Sub findMailViaRegnr() Dim mail As String, mailType As String sidsteRække = ActiveCell.SpecialCells(xlLastCell).Row
regnr = InputBox("RegistreringsNr.:", "Find mail via reg.nr.") If regnr <> "" Then række = søgEfterRegNrRække(regnr)
Rem Fundet række - test om der er WM i næste række 'Antagelse af alle regnr har 2 rækker PM / WM If række > 0 Then mail = Range("C" & række + 1) If mail <> "" Then MsgBox regnr & ": WM " & mail Else mail = Range("C" & række) If mail <> "" Then MsgBox regnr & ": PM " & mail Else MsgBox regnr & ": Ingen mailadresser" End If End If Else MsgBox "Regnr.: " & CStr(regnr) & " ej fundet" End If End If End Sub Private Function søgEfterRegNrRække(regnr) With ActiveSheet.Range("A1:A" & CStr(sidsteRække)) Set c = .Find(What:=regnr, LookIn:=xlValues, LookAt:=xlWhole) If Not c Is Nothing Then søgEfterRegNrRække = c.Row Else søgEfterRegNrRække = 0 End If End With End Function
Det var sgu hurtigt! Den fungerer næsten. Der er to problemer: 1. Jeg kom til at lave en fejl i opgave beskrivelsen. Der er 5 kolonner: A=Reg nr, B=Fornavn, C=Efternavn, D=Mail, E=WM / PM
2. Listen er desværre ikke ordnet særlig pænt, så der kan godt stå som følger:
12345 Hans Hansen hans@arb.dk WM 12345 Hans Hansen hans@hans.dk PM 12345 Hans Hansen WM 23456 Sine Sans sine@arb.dk WM 23456 Sine Sans sine@hotmail.com PM
Der er op til 4 rækker med samme reg. nr hvor WM og PM står i vilkårlig rækkefølge og den ene WM eller PM kan være blank, mens den anden er udfyldt. I tilfældet med Sine Sans vil makroen melde WM = sine@hotmail.com Er det noget du kan ordne?
Rem Version 2 Rem ========= Dim række As Long, sidsteRække As Long Dim mailVM As String, mailPM As String, nr, r As Long Public Sub findMailViaRegnr() Dim mail As String, mailType As String sidsteRække = ActiveCell.SpecialCells(xlLastCell).Row
regnr = InputBox("RegistreringsNr.:", "Find mail via reg.nr.") If regnr <> "" Then række = søgEfterRegNrRække(regnr) If række > 0 Then For r = række To sidsteRække nr = CStr(Range("A" & r)) If nr = regnr Then mail = Range("D" & r) mailType = Range("E" & r)
If mailType = "WM" And mail <> "" Then MsgBox regnr & ": WM " & mail Exit For Else If mailType = "PM" And mail <> "" Then mailPM = mail End If End If Else Rem test ved brud på reg.nr. If mailPM <> "" Then MsgBox regnr & ": PM " & mailPM Exit For End If End If Next r Else MsgBox "Regnr.: " & CStr(regnr) & " ej fundet" End If
Rem Test ved sidste række If mailPM <> "" Then MsgBox regnr & ": PM " & mailPM End If End If End Sub Private Function søgEfterRegNrRække(regnr) With ActiveSheet.Range("A1:A" & CStr(sidsteRække)) Set c = .Find(What:=regnr, LookIn:=xlValues, LookAt:=xlWhole) If Not c Is Nothing Then søgEfterRegNrRække = c.Row Else søgEfterRegNrRække = 0 End If End With End Function
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
