Try this one on, if it has any issues, just post back.

Sub saveDealerProfiles()
On Error GoTo saveDealerProfiles_Err

Const SAVEDIR = "\\Bpfile1\groups\CCC\Public\Dealer Profiles\"

Dim wbMain As Workbook, wbNew As Workbook
Dim wsTemplate As Worksheet, wsList As Worksheet, wsNew As
Worksheet, ws As Worksheet
Dim r As Range

' the workbook with the template and the list
Set wbMain = ActiveWorkbook
' the worksheet with the template
Set wsTemplate = wbMain.Sheets("Dealer Profile")
' the worksheet with the list
Set wsList = wbMain.Sheets("Dealer List")

' point to the first cell in the list of dealers
Set r = wsList.Range("A2")

' hide the creation of new workbooks
Application.ScreenUpdating = False

' once oyu hit the end of the list there will be blank cells
Do While Not r.Value = ""
' populate the field in the template that the lookups use
wsTemplate.Range("D4").Value = r.Value

' create the new workbook
Set wbNew = Workbooks.Add
Set wsNew = wbNew.Sheets.Add
wsNew.Name = wsTemplate.Range("J1")

' delete all worksheets except for the new one
Application.DisplayAlerts = False
For Each ws In wbNew.Sheets
If Not ws.Name = wsNew.Name Then ws.Delete
Next ws
Application.DisplayAlerts = True
Set ws = Nothing

' copy the cells from the template to the new worksheet,
pasting values only
wsTemplate.Cells.Copy
wsNew.Cells.PasteSpecial xlPasteValues

' save the workbook
wbNew.SaveAs SAVEDIR & wsNew.Name & ".xls"

' this pointer will be orphaned after closing the workbook so
remove it
Set wsNew = Nothing

' close the workbook
wbNew.Close

' move to the next cell in the list column
Set r = r.Offset(1, 0)
Loop
MsgBox "Dealer Profiles have been exported to:" & vbCrLf & vbCrLf &
SAVEDIR

' clean up
saveDealerProfiles_Goodbye:
Application.ScreenUpdating = True
Set r = Nothing
Set wsList = Nothing
Set wsTemplate = Nothing
Set wbNew = Nothing
Set wbMain = Nothing
Exit Sub
' hits here if there's an error
saveDealerProfiles_Err:
MsgBox "NUMBER: " & Err.Number & vbCrLf & "Description:" & vbCrLf &
Err.Description
Resume saveDealerProfiles_Goodbye
End Sub

Jess wrote:
I want each of the copies a separate workbook.

Jason Lepack wrote:
Ok that makes much more sense.

Now, you want each of these template copies in a new workbook? Or do
you want them just on seperate sheets in the same workbook?


Jess wrote:
I tried an If statement and I cant get it to work. I have 2 tabs. One
is Dealer List. It contains a Dealer ID Number, Name, Address, Phone,
Fax, etc... The other is Dealer Profile which is a form template. I
have vlookups on the Dealer template that populate Address, Name
information when a dealer number is populated into cell D4 (DealerNum)
which in turns populates some NAme/Adddress information within the
template. What I'm trying to do is write a code that takes the Dealer
ID Number from column A in my Dealer List tab populate D4 with it, make
a copy of the tab, break the links, save the copy to a specified
location, close the workbook, then take the next Dealer ID Number in
column A and populate the template again in a loop until it comes
accross a blank cell in column A of the Dealer List tab.

Jason Lepack wrote:
What exactly would you like this to do? List step by step instructions
on what you need and list cell and worksheet(tab) locations of all the
important information.

Cheers,
Jason Lepack


Jess wrote:
I am having a problem with looping. Basically I am trying to pull one
number from a list on a separate tab, put it in a cell in template form
and save it and then take the next number in the list and populate it
in the same cell in the template. The way I'm doing it, it's saveing a
workbook for every number between the first number in my list and the
last rather than every number that is populated in the cell... If that
makes sence. Can anyone help? (Go easy on my, I'm new)

Sheets("Dealer List").Select
For n = Range("A2") To Range("A48")
Range("D4") = n

Sheets("Dealer Profile").Select
Sheets("Dealer Profile").Copy
Range("C4:H7").Select
Range("D4").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Shapes("Button 2").Select
Application.CutCopyMode = False
Selection.Delete
ActiveSheet.Shapes("Button 3").Select
Application.CutCopyMode = False
Selection.Delete
Dim FileN
FileN = Range("J1")
ChDir "\\Bpfile1\groups\CCC\Public\Dealer Profiles"
ActiveWorkbook.SaveAs FileName:= _
FileN, FileFormat:=xlNormal _
, Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWorkbook.Close

Next n