Could you show me if I wanted to copy Col.F as well as Col.E what would I
change? I put E:F but it gave me error. I may have names next to phone number
that I want to copy them over too.

Other than that your VBA worked very well thank you so much.

JLatham wrote:
I believe you'll find that this code will work to accomplish the task,
without duplicated phone numbers on any row also.
I recommend making a copy of your workbook to do the testing in - since if
you make a change to the code (or not) that ends up causing existing entries
to be overwritten, they'll be gone forever. So make a copy of the workbook
and then ...

To put the code to work, first put it into your workbook:
Press [Alt]+[F11] to open the Visual Basic (VB) Editor. In the VB Editor
use its menu toolbar to choose Insert | Module. The copy the code and paste
it into the code module presented to you. Make any changes you need to to
the Const values I've marked with ' change? to reflect the actual names and
setup of your two worksheets. Close the VB Editor. To try it out, use Tools
| Macro | Macros and highlight the macro's name and click the [Run] button.

Here is the code:

Sub FindPhoneNumbers()
Const resultsSheet = "Sheet1" ' change?
Const zipColumn = "A" ' change?
Const firstRowToCheck = 1 ' change?
Dim lastZipColumnRow As Long
Dim zipRange As Range
Dim anyZip As Object

Const tableSheet = "Sheet2" ' change?
Const tableStartCol = "A" ' change?
'assumes all columns from A through D have
'zip codes to check on each row
Const tablePhoneNoCol = "E" ' change?
Const tableFirstRow = 1 ' change?
Dim lastTableRow As Long
Dim tableColRange As Range
Dim anyTableZip As Object
Dim offsetToPhone As Integer
Dim phoneFound As String
Dim phoneMatchFlag As Boolean
Dim startCol As Integer
Dim endCol As Integer
Dim colLoop As Integer
Dim tmpAddress As String
Dim ckPhoneEntry As Integer

'find out some things about the Results sheet
lastZipColumnRow = Worksheets(resultsSheet). _
Range(zipColumn & Rows.Count).End(xlUp).Row
'set up to examine zip codes on Results sheet
Set zipRange = Worksheets(resultsSheet). _
Range(zipColumn & firstRowToCheck & ":" & zipColumn _
& lastZipColumnRow)
'find out things about the table and table sheet
lastTableRow = Worksheets(tableSheet). _
Range(tableStartCol & Rows.Count).End(xlUp).Row
startCol = Range(tableStartCol & "1").Column
endCol = Range(tablePhoneNoCol & "1").Column - 1

For Each anyZip In zipRange ' each entry on Results sheet
For colLoop = startCol To endCol ' each column in lookup table
offsetToPhone = Range(tablePhoneNoCol & "1").Column - colLoop
tmpAddress = Range(tableStartCol & tableFirstRow). _
Offset(0, colLoop - 1).Address & ":" & _
Range(tableStartCol & tableFirstRow). _
Offset(lastTableRow - tableFirstRow, colLoop - 1).Address
'set reference to this column in the lookup table
Set tableColRange = Worksheets(tableSheet).Range(tmpAddress)
'start looking for matches to zip codes
For Each anyTableZip In tableColRange
If anyTableZip.Value = anyZip.Value Then
'we have a zip code match
'get the associated phone #
phoneFound = anyTableZip.Offset(0, offsetToPhone)
'has this phone # already been reported?
ckPhoneEntry = 1 ' offset 1 col from zip code on Results Sheet
phoneMatchFlag = False
Do Until IsEmpty(anyZip.Offset(0, ckPhoneEntry))
If phoneFound = anyZip.Offset(0, ckPhoneEntry).Value Then
phoneMatchFlag = True
Exit Do
End If
ckPhoneEntry = ckPhoneEntry + 1
Loop ' reported phone check loop end
If phoneMatchFlag = False Then
'no match found, add new phone # to row
anyZip.Offset(0, ckPhoneEntry) = phoneFound
End If
End If
Next ' end anyTableZip loop
Next ' end colLoop loop
Next ' end anyZip loop
End Sub

Hello all,

[quoted text clipped - 37 lines]
94597 925 921 925 932 925 933 925 933 925 922 926 932
94593 925 932

--
Message posted via http://www.officekb.com