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

Board Regular
Joined
Dec 10, 2003
Messages
77
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
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,623
Office Version
  1. 2007
Platform
  1. Windows
Try this:

Code:
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

Board Regular
Joined
Dec 10, 2003
Messages
77
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

Well-known Member
Joined
Dec 3, 2018
Messages
12,623
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to help you. Thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,130,310
Messages
5,641,450
Members
417,210
Latest member
rins

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top