以下のﾏｸﾛをお試しください｡

ｵﾘｼﾞﾅﾙの住所録は､ｼｰﾄ[Sheet1]のA列に名前が､B列に住所があるとします｡
ﾗﾝﾀﾞﾑに抽出した結果は､ｼｰﾄ[Sheet2]のA列とB列に代入します｡
名前と住所の両方が重複しているﾃﾞｰﾀは抽出しないようにしてあります｡

なお､もしｵﾘｼﾞﾅﾙの3000件から重複分を除いて1000件未満になっていると､このﾏｸﾛは無限ﾙｰﾌﾟに陥ってしまいます｡計算に時間がかかりすぎるようでしたら､ESCｷｰをｸﾘｯｸしてﾏｸﾛを中断してください｡

Option Explicit

Private SourSheet As String, DestSheet As String, Nums As Long

'ﾒｲﾝﾌﾟﾛｸﾞﾗﾑ
Sub main()
 SourSheet = "Sheet1"  'ｵﾘｼﾞﾅﾙのｼｰﾄ名
 DestSheet = "Sheet2"  '抽出先のｼｰﾄ名
 Nums = 1000  '抽出件数
 
 Dim name As String, address As String
 Dim maxrow As Long, i As Long, r As Long
 maxrow = Worksheets(SourSheet).Range("A1").End(xlDown).Row
 Call makeDestSheet
 
 i = 0
 While (i < Nums)
 r = Round(Rnd() * maxrow, 0)
 If (r = 0) Then r = 1
 name = Worksheets(SourSheet).Cells(r, 1).Value
 address = Worksheets(SourSheet).Cells(r, 2).Value
 If (isDup(name, address, i) = False) Then
 i = i + 1
 Call addItem(name, address, i)
 End If
 Wend
End Sub

'重複しているかどうか
Function isDup(name As String, address As String, n As Long) As Boolean
 Dim i As Long
 isDup = False
 For i = 1 To n
 If (Worksheets(DestSheet).Cells(i, 1) = name And Worksheets(DestSheet).Cells(i, 2) = address) Then
 isDup = True
 i = n + 1
 End If
 Next i
End Function

'1行追加
Sub addItem(name As String, address As String, n As Long)
 Worksheets(DestSheet).Cells(n, 1).Value = name
 Worksheets(DestSheet).Cells(n, 2).Value = address
End Sub

'ﾃﾞｰﾀｼｰﾄ作成
Private Sub makeDestSheet()
 Dim ws As Worksheet
 Dim flag As Boolean
 
 flag = False
 For Each ws In Worksheets
 If ws.name = DestSheet Then flag = True
 Next ws
 If (flag = True) Then
 Worksheets(DestSheet).Cells.Clear
 Else
 Set ws = Worksheets.Add
 ws.name = DestSheet
 End If
End Sub

まず以下の方法にしたがって重複したﾃﾞｰﾀが見えないようにします｡
重複ﾃﾞｰﾀを削除する?ﾌｨﾙﾀｵﾌﾟｼｮﾝ:Excel ｴｸｾﾙの使い方-ﾃﾞｰﾀﾍﾞｰｽ/検索

次に以下の方法にしたがってﾃﾞｰﾀとして使っていない列にrand関数を入力しその列で並べ替えをします｡
先頭から欲しい行数だけを抜き出してください｡
ﾗﾝﾀﾞﾑな並べ替え?RAND関数:Excel ｴｸｾﾙの使い方-ﾃﾞｰﾀﾍﾞｰｽ/検索

重複したﾃﾞｰﾀを完全に削除してしまっても良ろしければ以下のような方法もございます｡
Excel2007で重複ﾃﾞｰﾀを削除する?重複の削除:Excel 2007 ｴｸｾﾙ2007の使い方

ご確認ください｡