Hej Carsten.
Hvordan man sletter dubletter i Word ved jeg ikke, men hvis du kan bruge
Excel, kan nedenstående makro bruges.
Makroen er lavet af Leo Heuser og jeg har modificeret den en lille smule.
Du skal kopierer dine 2 lister med e-mail adresser ind i det FØRSTE ark i
kolonne A (A1) og B (B1). Dubletter i kolonne A bliver slettet.
Bemærk venligst, at evt. dubletter i kolonne A alene, ikke bliver slettet og
det samme gør sig gældende for kononne B.
Option Explicit
'Sæt selv "True" eller "False" i
' DeleteDuplicate = False
' FormatDuplicate = False
'----------------------------
Sub DuplicatesInTWORanges()
'Do NOT controle for dublets in each column only compare
' 2 columns, jbo use: DuplicatesInONERange
'leo. heuser, January 30, 2002
'Finds elements in one sheetrange (ValuesInThisRange)
'if they exist in another sheetrange (FoundInThisRange)
'Each range may consist of contiguous or non-contiguous ranges.
'A list of the duplicates may be inserted in a new sheet.
'The list contains values and references.
Dim AddressCollection As New Collection
Dim CellAddress As String
Dim CheckAddress As String
Dim Counter As Long
Dim DeleteDuplicate As Boolean
Dim Dummy
Dim DuplicateRange As Range
Dim DuplicatesExist As Boolean
Dim Element
Dim FormatColor As Long
Dim FormatDuplicate As Boolean
Dim FoundInThisRange As Range
Dim IsExternal As Boolean
Dim lColumn As Long
Dim lRow As Long
'Dim StartCell As Range
Dim SubArray As Variant
Dim ValueCollection As New Collection
Dim ValuesInThisRange As Range
Dim ws1 As Object
Set ws1 = Worksheets(1)
With ws1
Set ValuesInThisRange = .Range("A1:A" & .Cells(Rows.count,
1).End(xlUp).Row)
Set FoundInThisRange = .Range("B1:B" & .Cells(Rows.count,
2).End(xlUp).Row)
End With
DeleteDuplicate = True
FormatDuplicate = False
FormatColor = 3 ' Red
If FoundInThisRange.Parent.Name <> _
ValuesInThisRange.Parent.Name Then
IsExternal = True
End If
On Error Resume Next
For Counter = 1 To FoundInThisRange.Areas.count
SubArray = FoundInThisRange.Areas(Counter).Value
For lRow = LBound(SubArray, 1) To UBound(SubArray, 1)
For lColumn = LBound(SubArray, 2) To UBound(SubArray, 2)
If Not IsEmpty(SubArray(lRow, lColumn)) Then
CellAddress = _
FoundInThisRange.Areas(Counter).Cells(lRow, _
lColumn).Address(external:=IsExternal)
ValueCollection.Add CellAddress, _
CStr(SubArray(lRow, lColumn))
End If
Next lColumn
Next lRow
Next Counter
For Counter = 1 To ValuesInThisRange.Areas.count
SubArray = ValuesInThisRange.Areas(Counter).Value
For lRow = LBound(SubArray, 1) To UBound(SubArray, 1)
For lColumn = LBound(SubArray, 2) To UBound(SubArray, 2)
CellAddress = _
ValuesInThisRange.Areas(Counter).Cells(lRow, _
lColumn).Address(external:=IsExternal)
ValueCollection.Add CellAddress, _
CStr(SubArray(lRow, lColumn))
If Err.Number = 457 Then
Err.Clear
CheckAddress = _
ValueCollection.Item(CStr(SubArray(lRow, lColumn)))
If Intersect(ValuesInThisRange, _
Range(CheckAddress)) Is Nothing Then
DuplicatesExist = True
AddressCollection.Add _
ValuesInThisRange.Areas(Counter).Cells(lRow, _
lColumn).Address
If DuplicateRange Is Nothing Then
Set DuplicateRange = _
ValuesInThisRange.Areas(Counter).Cells(lRow,
lColumn)
Else
Set DuplicateRange = Union(DuplicateRange, _
ValuesInThisRange.Areas(Counter).Cells(lRow,
lColumn))
End If
End If
End If
Next lColumn
Application.StatusBar = CellAddress
Next lRow
Next Counter
If DuplicatesExist = False Then
MsgBox "No duplicates exist.", vbInformation
Exit Sub
End If
If FormatDuplicate Then DuplicateRange.Font.ColorIndex = FormatColor
If DeleteDuplicate Then DuplicateRange.Delete shift:=xlUp
End Sub
Med venlig hilsen
Jørgen Bondesen
"Carsten J" <cajuth2630dk@hotmail.com> wrote in message
news:c6ssan$e50$1@sunsite.dk...
> Hey,
>
> Jeg har to forskellige lange dokumenter med mailadresser...
>
> Nogle mailadresser optræder i begge lister.
>
> Jeg skal sende mail til begge lister... men jeg vil ikke sende mailen to
> gange
> til samme modtager!
>
> Kan man lave en makro, som kan undersøge, hvilke adresser som er
dubletter?
> Og evt. automatisk slette de overflødige (altså dem der optræder begge
> steder)
>
> Eller skal man programmere et seperat program til det ?
>
> --
> Mvh.
> Carsten
>
> cajuth2630dk(remove_all_this_in_the_brackets)@hotmail.com
> cajuth2630dk(fjern_dette_i_parantes)@hotmail.com
> sgftr690206
>
>
>
>
|