26. oktober 2005 - 12:15Der er
34 kommentarer og 1 løsning
rense adressedata
Hej Jeg skal have renset en fil med navne og adresse oplysninger, som ligger vandret under hinanden over i en databasetruktur. i dag står data eksempelvis sådan her:
Jens O. Vadstrup Teknikker Jens Ove Vadstrup Statsborgerskab: Danmark Vesterløkken 22 8305 Samsø Født: 30.03.1955
Men nogen gange står stillingsbetegnelsen der ikke, så navn står der to gange, i andre tilfælde er der mellem vej og postnummeret en stedangivelse. Med andre ord adressefeltet kan være mellem 6 og 8 linier. Jeg har brug for at lave en automatiseret formel, så i stedet for at have data ustruktureret i en kolonner laver følgende struktur: navn, stilling, navn på stemmeseddel, vej, postnummer, statsborgerskab.
Eftersom der ikke er et bestemt system i tingene, tror jeg ikke at du kan automatisere processen. Hverken med en formel eller en makro. Ingen af delene kan jo skelne mellem om det, der står i en celle er et navn eller en stillingsbetegnelse.
jeg tænkte om man kun lave en hvis-formel eller lignende (kan bare ikke selv overskue den :-)) Den skulle putte den celle, der hedder noget med "født:" i en bestemt celle. Cellen over "født" er altid postnummeret, så den skal i en bestemt celle. en anden formel skal lede efter statsborgskab: og putte det i en celle og herefter skal en anden formel tage henholdsvis det, som ligger lige over og nedenunder og pitte i hver sin celle. Så har vi da næsten det hele.
klart, men det er også fint, men hvordan lyder en formel, der skal have indholdet i en celle, hvis det eksempelvis indeholder ordet født: - altså hvordan laver jeg en hvisformel med trunkering/wildcard. Når jeg laver =hvis(a2="født*";a2;""), så sker der ingenting
Løsningen er baseret på den forudsætning at ingen titler har de samme første fire bostaver fælles med de første fire bogstaver af navnet. Hvis det ER tilfældet skal du rette antallet af testbogstaver i formeln i C1, fx =HVIS(VENSTRE(A2;8)<>VENSTRE(A1;8);A2;""), hvis du vil teste på otte bogstaver. Hvis nogen kan hedde præcis det samme som deres stilling, så altså A1 og A2 er helt ens, også selv om der står en stilling i A2 bryder logikken sammen. Ellers skulle det virke.
Nu opstår det så det problem, at du ikke umiddlebart kan kopiere formlen nedad. Kopierer du den til B2 osv, vil den stadig teste på de data, der står ovenfor. Derfor skal formlen altid kopieres til den første række med data i næste gruppe. Altså den den række hvor navnet i næste gruppe står.
hej igen. har du et smart forslag til, hvordan man kan kopiere den ned over 12000 navne og adresser, så en kopiere ned til den første rækker med data. Jeg kan jo ikke bare kopiere formlen og eks. 7 tomme rækker, når der er forskel på, hvor mange rækker hvert felt har - 6-8.
Nej, derfor kan du ikke umiddelbart bruge fyldhåndtaget. Eller retter det kan du, men så skal du bare bagefter slette en grusom masse rækker. Så den eneste løsning er, som jeg skrev ovenfor at kopiere formlen, og så indsætte den ud for første række i hver gruppe.
hej igen kom i tanker om følgende. kan man lave en makro, der går x-antal linier ned hver gang, der kommer en linie med teksten "født", så sletter den alt det ovenstående
'*** VIKTIG! OVERSKRIFER OG ANNEN TEKST SOM IKKE ER DATA, MÅ FJERNES FØRST.
Public Sub RensAdrData() Dim n As Long, i As Long, r As Long Dim counter As Long Dim c As Range Dim vdB() As Variant Dim lFirstRow As Long Dim vRowColOffst() As Variant
Application.ScreenUpdating = False
'** SETTER INN EN MIDLERTIDIG RAD ØVERST, TIL HEJLP FOR 1. POST Rows(1).Insert Cells(1, 1).Value = "Født:"
'** SLETTER EVENTUELLE TOMME RADER r = Cells(Rows.Count, 1).End(xlUp).Row For n = r To 1 Step -1 If IsEmpty(Cells(n, 1)) Then Cells(n, 1).EntireRow.Delete End If Next
'** SETTER INN TOMME RADER FOR DATA SOM EVENTUELT MANGLER '** TESTER KUN PÅ STILLING OG STED '** SETTER INN 2 TOMME RADER ETTER HVER POST counter = -1 ' teller opp antall "Født:", må trekke for den i 1.rad r = Cells(Rows.Count, 1).End(xlUp).Row For n = r To 1 Step -1 With Cells(n, 1) Trim (.Text) If Left(.Text, 5) = "Født:" Then counter = counter + 1 If Left(.Offset(3).Text, 15) = "Statsborgerskab" Then Rows(.Offset(2).Row).Insert End If If Left(.Offset(7).Text, 5) = "Født:" Then Rows(.Offset(6).Row).Insert End If Rows(.Offset(1).Row & ":" & .Offset(2).Row).Insert End If End With Next
'** SLETTER RADER SOM BLE SATT INN ØVERST '** ETTER DETTE BESTÅR HVER POST AV 10 RADER '** NY POST STARTER I RAD 1, 11, 21, 31 .... Range(Cells(1, 1), Cells(3, 1)).EntireRow.Delete
'** FOR RADER MED STATSBORGERSKAP OG POSTNUMMMER '** TREKKER DATA UT FRA STRENG OG KOPIERER TIL KOLLONNE 3 r = Cells(Rows.Count, 1).End(xlUp).Row For Each c In Range(Cells(1, 1), Cells(r, 1)) If Left(c.Text, 15) = "Statsborgerskab" Then c.Offset(, 2).Value = Right(c.Text, Len(c.Text) - 17) 'NB! prøv16 c.Offset(3, 2).Value = Left(c.Offset(3).Text, 4) End If Next
'** FØRSTE POST STARTER PÅ RAD 1, NESTE POST PÅ RAD 11 , 21 OSV. lFirstRow = 1 'denne øker med 10 for hver post
'** VISER I HVILKE CELLER DATA LIGGER I FORHOLD TIL lFirstRow '** NB! ØNSKES MERE DATA, ANGI HER HVOR DISSE DATA LIGGER vRowColOffst() = Array( _ Array(0, 1, 2, 4, 6, 3), Array(0, 0, 0, 0, 2, 2))
'** DIMMENSJONERER ARRAYET SOM DATA BLIR LAGT TIL ReDim vdB(counter, UBound(vRowColOffst(1), 1))
'** DA ER DET BARE Å FYLLE ARRAYET MED DATA For n = 1 To counter For i = 1 To UBound(vRowColOffst(1), 1) vdB(n, i) = Cells(lFirstRow, 1).Offset( _ vRowColOffst(1)(i), vRowColOffst(2)(i)) Next lFirstRow = lFirstRow + 10 'neste post 10 rader ned Next
'** SLETTER DE DATA SOM BLE KOPIERT TIL KOLLONNE 3 Columns(3).ClearContents
'** LEGGER TIL ET NYTT WORKSEET, SOM BLIR FYLT MED DATA '** FØRSTE CELLE SOM BLIR FYLT ER .Cells(RAD, KOLLONNE); HER Cells(2, 1) With ThisWorkbook.Worksheets.Add .Cells(2, 1).Resize(counter, UBound(vRowColOffst(1), 1)) = vdB End With
ingen spørsmål er dumme :-) alle må begynne et sted det letteste er å første lage en ny makro Meny : Verktøy -makroer registrer ny makro utfør så en enkel handlig som er merket en celle stopp opptakeren (firkant) igjen : Verktøy -makroer makro velg så rediger makro, du kommer til et vindu, ta bort absolutt all tekst i vinduet lim så inn all tekst fra min kommentar
Sub Makro1() ' ' Makro1 Makro ' Makro indspillet 27-10-2005 af Michael Holm ' ' Genvejstast:Ctrl+m ' Range("B2").Select Option Explicit Option Base 1
'*** VIKTIG! OVERSKRIFER OG ANNEN TEKST SOM IKKE ER DATA, MÅ FJERNES FØRST.
Public Sub RensAdrData() Dim n As Long, i As Long, r As Long Dim counter As Long Dim c As Range Dim vdB() As Variant Dim lFirstRow As Long Dim vRowColOffst() As Variant
Application.ScreenUpdating = False
'** SETTER INN EN MIDLERTIDIG RAD ØVERST, TIL HEJLP FOR 1. POST Rows(1).Insert Cells(1, 1).Value = "Født:"
'** SLETTER EVENTUELLE TOMME RADER r = Cells(Rows.Count, 1).End(xlUp).Row For n = r To 1 Step -1 If IsEmpty(Cells(n, 1)) Then Cells(n, 1).EntireRow.Delete End If Next
'** SETTER INN TOMME RADER FOR DATA SOM EVENTUELT MANGLER '** TESTER KUN PÅ STILLING OG STED '** SETTER INN 2 TOMME RADER ETTER HVER POST counter = -1 ' teller opp antall "Født:", må trekke for den i 1.rad r = Cells(Rows.Count, 1).End(xlUp).Row For n = r To 1 Step -1 With Cells(n, 1) Trim (.Text) If Left(.Text, 5) = "Født:" Then counter = counter + 1 If Left(.Offset(3).Text, 15) = "Statsborgerskab" Then Rows(.Offset(2).Row).Insert End If If Left(.Offset(7).Text, 5) = "Født:" Then Rows(.Offset(6).Row).Insert End If Rows(.Offset(1).Row & ":" & .Offset(2).Row).Insert End If End With Next
'** SLETTER RADER SOM BLE SATT INN ØVERST '** ETTER DETTE BESTÅR HVER POST AV 10 RADER '** NY POST STARTER I RAD 1, 11, 21, 31 .... Range(Cells(1, 1), Cells(3, 1)).EntireRow.Delete
'** FOR RADER MED STATSBORGERSKAP OG POSTNUMMMER '** TREKKER DATA UT FRA STRENG OG KOPIERER TIL KOLLONNE 3 r = Cells(Rows.Count, 1).End(xlUp).Row For Each c In Range(Cells(1, 1), Cells(r, 1)) If Left(c.Text, 15) = "Statsborgerskab" Then c.Offset(, 2).Value = Right(c.Text, Len(c.Text) - 17) 'NB! prøv16 c.Offset(3, 2).Value = Left(c.Offset(3).Text, 4) End If Next
'** FØRSTE POST STARTER PÅ RAD 1, NESTE POST PÅ RAD 11 , 21 OSV. lFirstRow = 1 'denne øker med 10 for hver post
'** VISER I HVILKE CELLER DATA LIGGER I FORHOLD TIL lFirstRow '** NB! ØNSKES MERE DATA, ANGI HER HVOR DISSE DATA LIGGER vRowColOffst() = Array( _ Array(0, 1, 2, 4, 6, 3), Array(0, 0, 0, 0, 2, 2))
'** DIMMENSJONERER ARRAYET SOM DATA BLIR LAGT TIL ReDim vdB(counter, UBound(vRowColOffst(1), 1))
'** DA ER DET BARE Å FYLLE ARRAYET MED DATA For n = 1 To counter For i = 1 To UBound(vRowColOffst(1), 1) vdB(n, i) = Cells(lFirstRow, 1).Offset( _ vRowColOffst(1)(i), vRowColOffst(2)(i)) Next lFirstRow = lFirstRow + 10 'neste post 10 rader ned Next
'** SLETTER DE DATA SOM BLE KOPIERT TIL KOLLONNE 3 Columns(3).ClearContents
'** LEGGER TIL ET NYTT WORKSEET, SOM BLIR FYLT MED DATA '** FØRSTE CELLE SOM BLIR FYLT ER .Cells(RAD, KOLLONNE); HER Cells(2, 1) With ThisWorkbook.Worksheets.Add .Cells(2, 1).Resize(counter, UBound(vRowColOffst(1), 1)) = vdB End With
pointene spiller ingen rolle ( du har ikke lov til å gi flere ) Jeg hadde en fin kveld foran pc-en i går kveld med makrokode og en lille cognac :-) (skjønner ikke de som spiller sudoku, når man kan gjøre dette )
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.
