vba code to save a template as the name of a cell

**Hirandavda** · 01-18-2008, 09:38 AM

Hi guys,

I am totally new to writing code and dont have much of a clue!! Tryiing to put bits and pieces together using books.

I have a list of 4000 reference numbers and for each of these I want to create a seperate workbook with the name of the referenc number. However, having a template setting. The current code that i have done, saves the existing file so it has existing information on it whiCh I dont want. To, sum up....I wnt excel to loop through my list creating a new file named with each of the refernce numbers stored in a directory of my prference...

Sounds confusing....I know..

Hope somebody can help....this is what I have so far:

Sub SaveFileAsDate()
Dim WSName As String, CName As String, Directory As String, savename As String
Dim NextRow As Long
Dim cellvalue As Boolean


WSName = "Sheet1"
'change "Sheet1" to sheet tab name containing cell reference
CName = "A1"
'change "A1" to the cell with your date


'   Ensure Sheet 1 is active
    Sheets("Sheet1").Activate
    
    NextRow = Application.WorksheetFunction. _
        CountA(Range("A:A"))
    
    Row = 1
    
    cellvalue = True
    
    Do While cellvalue
    
        Directory = "C:\Documents and Settings\Hdavda\Desktop\Test\"
            savename = Sheets("Sheet1").Cells(Row, 1).Text
        ActiveWorkbook.SaveAs Filename:=Directory & savename & ".xls"
        
        Row = Row + 1
        
        If Row > NextRow Then
        cellvalue = False
        End If
    Loop


End Sub

**Leith Ross** · 01-18-2008, 08:09 PM

Hello Hirandavda,

This code will create as many blank workbooks as there are rows with data with each name the same as what is in the cell.

Sub CreateWorkbooks()

  Dim Cell As Range
  Dim Directory As String
  Dim NextRow As Long
  Dim Rng As Range
  Dim Row As Long
  
   'This method is more reliable than using CountA
    Set NextRow = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
    Set Rng = Worksheets("Sheet1").Range("A1:A" & NextRow)
    Directory = "C:\Documents and Settings\Hdavda\Desktop\Test\"

      For Each Cell In Rng
        'Remove any spaces 
         If Trim(Cell) <> "" Then
            Workbooks.Add
              ActiveWorkbook.SaveAs Cell.Text & ".xls"
            ActiveWorkBook.Close
         End If
      Next Cell

End Sub

Sincerely,
Leith Ross