Create new file, populate it with data from another file, save it as per name in col A, repeat for all names listed in Col A

[richardcarter]

I have a main workbook (wokbook A) which just contains a list of names in col A. For each name, I need to create a new workbook, then populate it with data coming from another workbook (workbook B), then save the newly created workbook with the persons name in Col A .Reapeat for all people listed in Column A.

I was trying to adapt the following code which I was kindly provided by ranman in this post https://www.mrexcel.com/forum/members/ranman256.html. This code just creates blank new files without populating them, but for the life of me I cannot find a way to populate them before they are saved!

Hope someone can help.. many thanks.

Sub MakeSheetsFromList()
Dim col As New Collection
dim I as integer
dim vName

On Error Resume Next
Range("A1").Select
While ActiveCell.Value <> ""
col.Add ActiveCell.Value
ActiveCell.Offset(1, 0).Select 'next row
Wend

For i = 1 To col.Count
vName = "C:\My Documents" & col(i)
Workbooks.Add
ActiveWorkbook.SaveAs vName
ActiveWorkbook.Close False
Next
Set col = Nothing
End Sub

 

[DanteAmor]

Try this:

Sub MakeSheetsFromList()
    Dim i As Double, vName As String, vPath As String, rng As Range, lr As Double
    Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    vPath = "C:\My Documents\"
    '
    Set wb1 = ThisWorkbook
    Set ws1 = wb1.Sheets("Sheet1")              'name of sheet with names of the workbooks
    
    '***
    'Data from book b
    Set wb2 = Workbooks("workbook B.xlsx")      'name of workbook B to copy, it must be open
    Set ws2 = wb2.Sheets("sheet b")             'name of sheet to copy
    Set rng = ws2.Range("A1:D10")               'range to copy
    '***
    '
    lr = ws1.Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To lr
        vName = vPath & ws1.Cells(i, "A").Value
        Set wb3 = Workbooks.Add
        rng.Copy
        wb3.Sheets(1).Range("A1").PasteSpecial xlValues
        wb3.SaveAs vName
        wb3.Close False
    Next
    MsgBox "End"
End Sub

 

[richardcarter]

Thank you so much for that.. its a great help and I know you must have spent quite a bit of time on that which I really appreciate and am very grateful for. Kindest regards.

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.