CODEWITHSUNDEEP
loopsexcelvba
Mark Austin
Mark Austin

Reputation: 129

Loop Copy Cell Name As New Workbook

I am trying to read a column of cells and when it finds a cell with info in it create a new work book and use that cell as the name. I am trying to save it to a folder on my desktop named Book1. I am a little stuck and not sure where to go next any ideas??? 

Sub blair()
Dim Aname As String

For ptr = 2 To 300
    If Cells(ptr, "b") = vbNullString Then
        Cells(ptr, "b") = Cells(ptr, "a").Offset(-1, 0)

    ElseIf Cells(ptr, "b") > 0 Then
       Aname = ActiveCell.Value
       Workbooks.Add
       ActiveWorkbook.SaveAs Filename:=Aname & ".xls"
  End If
Next
End Sub

Upvotes: 1

Views: 252

Answers (1)

brettdj
brettdj

Reputation: 55672

One option is below.

  • checks that the Book1 folder exists on the user Desktop (works regardless of OS path)
  • the code creates a single sheet blank workbook, then saves it in this directory as the template for the new files to be created
  • for efficiency FileCopy is used to make the new versions, rather than creating, saving and closing a new workook repeatedly
  • null values are skipped
  • the code uses a variant array for quick processing of the values

Some further minor tweaks may be needed if your data format varied. For example, testing for characters that cannot be used in file names.

code

Sub NB()
    Dim X
    Dim lngCnt As Long
    Dim strDT As String
    Dim strNewBook As String
    Dim objWS As Object
    Dim WB As Workbook
    Dim bNewBook As Boolean

    Set objWS = CreateObject("WScript.Shell")
    strDT = objWS.SpecialFolders("Desktop") & "\Book1"
    If Len(Dir(strDT, vbDirectory)) = 0 Then
        MsgBox "No such directory", vbCritical
        Exit Sub
    End If
    X = Range([a1], Cells(Rows.Count, "A").End(xlUp)).Value2
    For lngCnt = 1 To UBound(X, 1)
        If Len(X(lngCnt, 1)) > 0 Then
            If Not bNewBook Then
                'make a single sheet workbook for first value
                Set WB = Workbooks.Add(1)
                WB.SaveAs strDT & "\" & X(lngCnt, 1) & ".xls"
                strNewBook = WB.FullName
                WB.Close
                bNewBook = True
            Else
                FileCopy strNewBook, strDT & "\" & X(lngCnt, 1) & ".xls"
            End If
        End If
    Next
End Sub

Upvotes: 2

Related Questions