Fjern dubletter

Bemærk den kun skal slette ordet Wien hvis det er det sidste ord i kolonne B :-)

Hvis kolonne D er ledig så prøv denne makro
den sletter evt. dubletter
Husk at lave en backup først.

Sub SletDubletter()
Dim c, r, t, t2, i, rk
rk = Range("A65500").End(xlUp).Row
For i = 1 To rk
Cells(i, 4) = Cells(i, 1) & Cells(i, 2) & Cells(i, 3)
Next
Cells(1, 4).Select
c = ActiveCell.Column
r = Cells(65500, c).End(xlUp).Row
Range(Cells(1, c), Cells(65500, c).End(xlUp)).Select
For t = 1 To r
If Cells(t, c) <> "" Then
For t2 = t + 1 To r
If Cells(t, c) = Cells(t2, c) Then
Cells(t2, c) = ""
End If
Next
End If
Next
On Error Resume Next
Selection.Columns.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Range("D1:D65500") = ""
Range("A1").Select
End Sub

og denne sletter navn i B hvis=C samt punktum i C hvis <=7 tegn.

Sub Split()
Dim rk, r, l
rk = Range("A65500").End(xlUp).Row
For r = 1 To rk
l = Len(Cells(r, 3))
If Right(Cells(r, 2), l) = Cells(r, 3) Then
Cells(r, 2) = Left(Cells(r, 2), Len(Cells(r, 2)) - l)
End If
If Len(Cells(r, 3)) < 7 Then Cells(r, 3) = Cells(r, 3) & "."
Next
End Sub

ret lige denne til:
If Len(Cells(r, 3)) <= 7 Then Cells(r, 3) = Cells(r, 3) & "."

Kanon, kan det skrives samme til 1 kode?

jeg kan da prøve :-)

Sub SletDubletter()
Dim c, r, t, t2, i, rk, l
rk = Range("A65500").End(xlUp).Row
For i = 1 To rk
Cells(i, 4) = Cells(i, 1) & Cells(i, 2) & Cells(i, 3)
Next
Cells(1, 4).Select
c = ActiveCell.Column
r = Cells(65500, c).End(xlUp).Row
Range(Cells(1, c), Cells(65500, c).End(xlUp)).Select
For t = 1 To r
If Cells(t, c) <> "" Then
For t2 = t + 1 To r
If Cells(t, c) = Cells(t2, c) Then
Cells(t2, c) = ""
End If
Next
End If
Next
On Error Resume Next
Selection.Columns.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Range("D1:D65500") = ""
rk = Range("A65500").End(xlUp).Row
For r = 1 To rk
l = Len(Cells(r, 3))
If Right(Cells(r, 2), l) = Cells(r, 3) Then
Cells(r, 2) = Left(Cells(r, 2), Len(Cells(r, 2)) - l)
End If
If Len(Cells(r, 3)) <= 7 Then Cells(r, 3) = Cells(r, 3) & "."
Next
Range("A1").Select
End Sub

skift evt denne (3 sidste) linie:
If Len(Cells(r, 3)) <= 7 Then Cells(r, 3) = Cells(r, 3) & "."

ud med denne:
If Len(Cells(r, 3)) < 7 And Right(Cells(r, 3), 1) <> "." Then Cells(r, 3) = Cells(r, 3) & "."

så der ikke kommer mere end 1 punktum efter navn

Jeg kunne ikke få det til at virke. Eller det vil sige min PC døde :D
Prøver igen, men vil lige høre om dette her er muligt

England    University Of East London     London
England    University Of Edinburgh     Edinbur
England    University Of Edinburgh     Edinbur
England    University Of Essex            Colches

Her ses det at navnet i C er forkortet. Kan man lave det sådan at Navn i C forsvinder hvis det udgør en del af sidste ord i B ?

Sådan at

England    University Of Edinburgh

ikke bliver til

England    University Of Edinbur

?  :-)

Min PC dør tror jeg. Eller der sker ikke noget i LANG tid.

Hvor længe kan det age på ca. 10.000 rækker?

Bærbar: Centrino 1.7 GHz 512MB ram og der kører ikke andre programmer end min IE her på eksperten.dk

kikker på det

jeg kørte en test med 7000 rækker - ca 10 sekunder
Bærbar Celeron 1,5 Hz, 400 MHz FSB 1 MB L2 cache 512MB DDR2

Der virker :D

Hvis det sidste kan lade sig gøre så er det vidunderligt :-)

jeg skal prøve - efter spisetid :-)

Super :-)

så tror jeg den virker :-)

Sub SletDubletter()
Dim c, r, t, t2, i, rk, l, lb, lc
Application.Calculation = xlManual
Application.ScreenUpdating = False
rk = Range("A65500").End(xlUp).Row
For i = 1 To rk
Cells(i, 4) = Cells(i, 1) & Cells(i, 2) & Cells(i, 3)
Next
Cells(1, 4).Select
c = ActiveCell.Column
r = Cells(65500, c).End(xlUp).Row
Range(Cells(1, c), Cells(65500, c).End(xlUp)).Select
For t = 1 To r
If Cells(t, c) <> "" Then
For t2 = t + 1 To r
If Cells(t, c) = Cells(t2, c) Then
Cells(t2, c) = ""
End If
Next
End If
Next
On Error Resume Next
Selection.Columns.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Range("D1:D25500") = ""
rk = Range("A65500").End(xlUp).Row
For r = 1 To rk
lb = Len(Cells(r, 2)): lc = Len(Cells(r, 3))
For i = 1 To lb
If Mid(Cells(r, 2), i, 1) = " " Then t = i
Next
Cells(r, 5) = Mid(Cells(r, 2), t + 1, 20)
If Left(Cells(r, 5), 4) = Left(Cells(r, 3), 4) And Len(Cells(r, 5)) >= lc Then Cells(r, 3) = ""
If Len(Cells(r, 3)) <= 7 And Right(Cells(r, 3), 1) <> "." And Cells(r, 3) <> "" Then
Cells(r, 3) = Cells(r, 3) & "."
End If
Next
Range("E1:E25500") = ""
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Range("A1").Select
End Sub

Det tog den 18 minutter :D

Den skriver fx stadigvæk:

England |University Of Kent At Canterbury |Canterb.

Nogle steder har den fjernet ordet i C
Det må meget gerne være ordet i B den fjerner stedet.

Så det bliver:

England |University Of Kent At | Canterbury

Den skal altid vælge det længste ord hvis du forstår?

din kommentar 26/08-2006 18:07:40
Her ses det at navnet i C er forkortet. Kan man lave det sådan at Navn i C forsvinder hvis det udgør en del af sidste ord i B ?
???

min kørsel på:
England |University Of Kent At Canterbury |Canterb
giver:
England |University Of Kent At Canterbury

Prøv evt. min fil:

http://pmexcelent.dk/SplitBy.xls

den skal først gemmes på HD

Jeg prøver lige igen, det tager 18 min :-)

Østrig    Akademie Der Bildenden Künste Wien    Wien
Østrig    Akademie Der Bildenden Künste Wien    Wien
Østrig    Akademie Fûr Den Physiotherapeut…    Wien
England    University Of East London            London
England    University Of Edinburgh            Edinbur
England    University Of Edinburgh                Edinbur
England    University Of Essex                    Colches
England    University Of Kent At Canterbury    Canterb

Når jeg har kopieret ovenstående 8 linier, så jeg har 10.000 rækker
tager en kørsel 14 sekunder

Mht.

"Nogle steder har den fjernet ordet i C
Det må meget gerne være ordet i B den fjerner stedet."

Det var noget vrøvl fra min side. Det er rigtigt som du har lavet det. Jeg har set på den her liste i 14 timer og er lidt zZzZzZzZz

Glæder mig til at se når den har tænkt færdigt :-)

kan du ikke prøve med min fil og kopiere de 8 linier så du har 10.000 rækker
så vi kan se om det er det samme med den (min tid 14 sekunder)

Den laver stadigvæk

England    University Of Cambridge     Cambrid.

Prøv at skriv til brichardi@gmail.com så sender jeg dig min liste

Hmm...  min PC sender også langsomt...

Skriv lige her når den er modtaget

Filen fyldet små 15 MB, der må være et eller andet galt!

ok ikke modtaget endnu

Så skulle den være sendt. Min gmail siger den fylder 9.6 MB mens MSN sagde den fyldte 14.6 MB :-)

This is an automatically generated Delivery Status Notification

Delivery to the following recipient failed permanently:

    Din e-mail

Technical details of permanent failure:
PERM_FAILURE: SMTP Error (state 12): 552 Message size exceeds fixed maximum message size: 10240000 bytes

prøv igen der skulle være hul igennem

pm@madsen.tdcadsl.dk

jeg pakkede den med winrar, så fylder den under 1 mb

kan ikkeåbne den, har ikke pakke prg. winrar

hvor kan jeg få den?

http://www.tucows.com/preview/194276

ok har kørt test nu (18 min) zzzzzzzzzz

og du har ret, den ændrer ikke England    University Of Cambridge    Cambrid
det ser ud til, at hele kolonne B har et tomt mellemrum i alle navne sidst
i teksten, hvilket er årsag til omtalte problem.
Det skal vi nu nok finde en løsning på, det mest iriterende er dog at den er så længe om at lave en kørsel, så det vil jeg lige se om ikke kan løses

Med dit kendskab til listen, ved du om man evt. kunne nøjes med at teste
på kolonne B for at finde dubletter, dette alene vil speede tempoet op en del?

Fjern det tomme mellemrum i kolonne B:

Indsæt denne formel i celle D2
=FJERN.OVERFLØDIGE.BLANKE(B2)
marker celle D2 igen og træk ned til hvor værdier ender (række 9385)
(dette laver en kopi af kolonne B uden det sidste tomme mellemrum)
klik på kopi ikon
klik på pil i paste ikon og vælg indsæt værdier
træk hele det markerede i kolonne D over i kolonne B og slip

God morgen,

Jeg er ikke 100% sikker på at test på B er sikkert :-/
Jeg tror der måske er fx universitet der hedder det samme som ligger i flere lande. Men B og C sammen er sikker.

Arbejder lige med det du har skrevet :-)

God morgen
enig, skal minimum teste på B og C

Hastigheden kan fordobles, hvis følgende forudsætning er til stede.
eks. Østrig forekommer fra række 2 til række 437.
Hvis man kan regne med, de enkelte lande er samlet i hele listen,
så behøver vi kun køre en løkke med 2600, ide Frankrig forekommer ca 2500 gange
Umiddelbart ser det ud til at det er tilfældet, men man kunne evt. Sortere
listen efter kolonne A for at være sikker. ved ikke hvor vigtig hastigheden er?

Det virker! Bortset fra der også er punktum efter de byer der har mindre end 7 bogstaver, men det er egentlig fint nok :-)

Hastigheden i Excel er ikke vigtig. Jeg skal eksportere det til en MSSQL database.

Du må meget gerne smide et svar :-)

undgå punktum i byer med mindre en 7 bogstaver: så blot slette  <  i denne linie

If Len(Cells(r, 3)) <= 7 And Right(Cells(r, 3), 1) <> "." And Cells(r, 3) <> "" Then

Tak for en enestående hjælp! :-)

velbekom, det var en hård nød :-)