VBA Code not stopping when trying to create multiple workbooks from a list

[Kimber33]

Hi All,

I am hoping someone on here can help me figure my issue out
I have tried searching the internet and tried a few solutions and I am nearly there but having an issue.

I have a spreadsheet (obviously) that contains a list of names in column B, I want to create a macro that will create a new workbook for each name and name the files as that name in the list and save in a specific folder. The list can vary in size from 140 to 250 entries and I don't want it to include the title of the list or blank cells.

The code I have created so far creates the workbooks from the list but includes the title of the list and attempts to create further workbooks from blank cells which prompts a message advising the file already exists, pressing no then aborts the macro with an error.

Any help would be greatly appreciated

Here is the code I have managed to piece together so far:

[SIZE=1]Private Sub CommandButton1_Click()[/SIZE]
[SIZE=1]Dim wb As Workbook[/SIZE]
[SIZE=1]Dim [/SIZE][SIZE=1]Sht[/SIZE][SIZE=1] As Worksheet[/SIZE]
[SIZE=1]Dim [/SIZE][SIZE=1]Lrow[/SIZE][SIZE=1] As Long[/SIZE]
[SIZE=1]Dim Rng As Range[/SIZE]
[SIZE=1]Dim Count As Long[/SIZE]
[SIZE=1]Dim [/SIZE][SIZE=1]wbName[/SIZE][SIZE=1] As String[/SIZE]
[SIZE=1]
[/SIZE]
[SIZE=1]Set wb = ThisWorkbook[/SIZE]
[SIZE=1]Set Sht = wb.Sheets(2)[/SIZE]
[SIZE=1]LRow = Sht.Cells(Rows.Count, "B").End(xlUp).Row[/SIZE]
[SIZE=1]Set Rng = Sht.Range("B3:B" & LRow)[/SIZE]
[SIZE=1]Count = 1[/SIZE]
[SIZE=1]
[/SIZE]
[SIZE=1]	Do[/SIZE]
[SIZE=1]		Count = Count + 1[/SIZE]
[SIZE=1]		wbName = Sheet2.Range("B3" & Count).Value[/SIZE]
[SIZE=1]		Workbooks.Open ("C:\My Documents\Template.xls")[/SIZE]
[SIZE=1]		ActiveWorkbook.SaveAs FileName:="C:\My Documents\Archive\" & wbName & ".xls"[/SIZE]
[SIZE=1]		ActiveWorkbook.Cloase False[/SIZE]
[SIZE=1]	Loop Until Count = LRow[/SIZE]
[SIZE=1]End Sub[/SIZE]

 

[JackDanIce]

Untested, but try replacing all of your code with:

Private Sub CommandButton1_Click()
 
    Dim x           As Long
    Dim arr()       As Variant
    Dim wkbTemp     As Workbook
    Dim newTemp     As Workbook
    Const strSave   As String = "C:\My Documents\Archive\@Name.xls"
    
    Set wkbTemp = Workbooks.Open("C:\My Documents\Template.xls", ReadOnly:=True)
    ThisWorkbook.Activate
    
    Application.ScreenUpdating = False
    
    With Sheets(2)
        x = .Cells(.Rows.Count, 2).End(xlUp).row - 2
        arr = .Cells(3, 2).Resize(x).Value
    End With
    
    For x = LBound(arr, 1) To UBound(arr, 2)
        If Len(Trim$(arr(x, 1))) > 1 Then
            Set newTemp = wkbTemp.SaveAs(Replace(strSave, "@Name", arr(x, 1)))
            newTemp.Close False
            Set newTemp = Nothing
        End If
    Next x
    
    wkbTemp.Close False
    
    Application.ScreenUpdating = True
    
    Erase arr
    Set wkbTemp = Nothing
        
End Sub

Above won't check for duplicate file names, I'm assuming B3:B<last row=""> contain unique values.</last>

 

[Kimber33]

Hi JackDanIce,

Thank you for your quick reply.

When I run the code it comes up with a Compile error: Expected Function or variable
The first line is highlighted 'Private Sub CommandButton2_Click()
Running Compile VBAProjects highlights the .SaveAs on the 3rd line of the For statement.

I'll have a play around with it to see if I can get it working

Thank you

 

[JackDanIce]

Try following and check name of your macro procedure as well is mapped to the correct button object:

Private Sub CommandButton1_Click()
 
    Dim x           As Long
    Dim arr()       As Variant
    Dim wkbTemp     As Workbook
    Const strSave   As String = "C:\My Documents\Archive\@Name.xls"
    
    Set wkbTemp = Workbooks.Open("C:\My Documents\Template.xls", ReadOnly:=True)
    
    Application.ScreenUpdating = False
    
    With Sheets(2)
        x = .Cells(.Rows.Count, 2).End(xlUp).row - 2
        arr = .Cells(3, 2).Resize(x).Value
    End With
    
    For x = LBound(arr, 1) To UBound(arr, 2)
        If Len(Trim$(arr(x, 1))) > 1 Then
            wkbTemp.SaveAs (Replace(strSave, "@Name", arr(x, 1)))
            ActiveWorkbook.Close False
        End If
    Next x
    
    wkbTemp.Close False
    
    Application.ScreenUpdating = True
    
    Erase arr
    Set wkbTemp = Nothing
        
End Sub

 

[Kimber33]

I've checked it's mapped to the correct button object. I've run the new code and getting a type mismatch on this line:

arr = .Cells(3,2).Resize(x).Value

Many thanks for your help with this - it's much appreciated, it's going to save me a lot of work each week.

 

[JackDanIce]

You're welcome. Check column B on Sheets(2) does contain data at least in cell B3, made a slight adjustment, try:

Private Sub CommandButton1_Click()
 
    Dim x           As Long
    Dim arr()       As Variant
    Dim wkbTemp     As Workbook
    Const strSave   As String = "C:\My Documents\Archive\@Name.xls"
    
    Set wkbTemp = Workbooks.Open("C:\My Documents\Template.xls", ReadOnly:=True)
    
    With ThisWorkbook
        .Activate
        Application.ScreenUpdating = False
        With .Sheets(2)
            x = Application.Max(.Cells(.Rows.Count, 2).End(xlUp).row - 2, 1)
            arr = .Cells(3, 2).Resize(x).Value
        End With
    End With
    
    For x = LBound(arr, 1) To UBound(arr, 2)
        If Len(Trim$(arr(x, 1))) > 1 Then
            wkbTemp.SaveAs (Replace(strSave, "@Name", arr(x, 1)))
            ActiveWorkbook.Close False
        End If
    Next x
    
    wkbTemp.Close False
    
    Application.ScreenUpdating = True
    
    Erase arr
    Set wkbTemp = Nothing
        
End Sub