Fjerne Dubletter

[Allan Thustrup Mortensen]

Jeg har en liste med kundeoplysninger i excel, kundenummeret står i kollonne
A og andre oplysninger på kunderne står i de efterfølgende kollonner.

Kunderne forekommer tit mere end 1 gang, så jeg mangler en funktion til at
fjerne disse dubletter.

Jeg har rodet med at lave en VBA-kode til formålet, altså at slette rækken
med dubletten men jeg kan ikke få den til at virke.

Venlig hilsen

Allan

[Lars Klintholm]

Den 18 aug 2003 skrev Allan Thustrup Mortensen i dk.edb.regneark:

> Jeg har en liste med kundeoplysninger i excel, kundenummeret står
> i kollonne A og andre oplysninger på kunderne står i de
> efterfølgende kollonner.
>
> Kunderne forekommer tit mere end 1 gang, så jeg mangler en
> funktion til at fjerne disse dubletter.

Prøv med Data > Filter > Avanced Filter.
Copy to another location
Unique records only

--
Mvh.
LarsK

[Allan Thustrup Mortensen]

Tak Lars

Men jeg tænkte om det var muligt via VBA, at lave en funktion der gjorde
dette ??

Er det det ??

VH

Allan

"Lars Klintholm" <nospa...@klintholm.com> skrev i en meddelelse
news:Xns93DB960FDB8...@klintholm.com...

[Jørgen Bondesen]

Hej Allan

Det er det.

Prøv nedenstående som dels er fra (ved ikke) og så en lille bitte smule jeg
selv har lavet.

'////////////////////////////////

Option Explicit

Sub DeleteDuplicatesInColumn()

'Have all cell in range value?
Dim rCheckRange As Range
' Set rCheckRange = Range("a1:a24")

'or
Dim NoRows As Long
NoRows = Application.WorksheetFunction.CountA(Columns("A:A"))
Set rCheckRange = Range("A1:A" & NoRows)

Dim Cell As Range
Dim rRange As Range
For Each Cell In rCheckRange
Dim DummyRange As Range
Set DummyRange = Range(rCheckRange(1, 1), Cell)
If Application.CountIf(DummyRange, Cell.Value) > 1 Then

Dim DeleteRange As Range
If DeleteRange Is Nothing Then
Set DeleteRange = Cell
Else
Set DeleteRange = Union(DeleteRange, Cell)
End If
End If
Next Cell

'Row
DeleteRange.Delete Shift:=xlShiftUp

'or
' With DeleteRange.Font
' .ColorIndex = 3
' End With

Set rCheckRange = Nothing
Set DeleteRange = Nothing
Set DummyRange = Nothing
Set Cell = Nothing
End Sub

'/////////////////////////////////////

Med venlig hilsen
Jørgen Bondesen

"Allan Thustrup Mortensen" <rial...@oncable.dk> wrote in message
news:3f425403$0$21637$edfa...@dread11.news.tele.dk...

[Tommy Bak]

Hej
En makro mere:
Marker kolonnen (området) hvor dubletterne findes og kør makroen.
Først tømmer den cellerne med dubletter, derefter (vha. specialcells)
markeres alle tomme celler og hele linien slettes

Sub RemoveDuplicates()
Dim AllCells As Range, Cell As Range
Dim Uniqs As New Collection
Application.ScreenUpdating = False
Set AllCells = Selection
On Error Resume Next
For Each Cell In AllCells
Uniqs.Add Cell.Value, CStr(Cell.Value)
If Err.Number <> 0 Then Cell = ""
Err.Clear
Next Cell
On Error Goto 0
AllCells.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete Shift:=xlUp
Application.ScreenUpdating = True
End Sub

mvh
Tommy Bak

[Tommy Bak]

Der gled lige en linie ud.
Den er ikke absollut nødvendig, men den rydder lige lidt op

Set Uniqs = Nothing 'ups
End Sub

mvh
Tommy Bak

"Tommy Bak" <tomm...@netscape.net> skrev i en meddelelse
news:bhu305$120t$1...@news.cybercity.dk...

[Allan T. Mortensen]

1000 Tak, det var simpelthen lige hvad jeg skulle bruge.
Den virker fantastisk godt

VH

Allan

"Tommy Bak" <tomm...@netscape.net> wrote in message
news:bhu3rl$12pk$1...@news.cybercity.dk...

[Tommy Christensen]

Velbekomme Allan :-)
mvh
Tommy Bak

--
Posted via Mailgate.ORG Server - http://www.Mailgate.ORG