Copying cells from one workbook to another and saving an individual file for each cell

[Andyg666]

Hi,
I am new to macros but hope you can help me.
I have a list of items and related information (model, serial number etc) and I need a macro so that I can press a button and export the item name and serial number of each item into another workbook for each item on the original list including a pop up option of where these new workbooks would be saved.

I hope this makes sense, please help

 

[mumps]

Make sure that the file already contains a sheet named "Certificate" which of course contains a certificate with no data from row 8 down. This macro will start by asking you to select a save folder for the file. If the save folder will always be the same, it can be hard coded so you don't have to select it each time. Please advise.

Sub CreateFiles()
    Application.ScreenUpdating = False
    Dim sPath As String, srcWS As Worksheet, lCol As Long, item As Range
    Set srcWS = Sheet1
    lCol = srcWS.Cells(3, Columns.Count).End(xlToLeft).Column
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a save folder for this file (" & ActiveSheet.Name & ")."
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count > 0 Then
            sPath = .SelectedItems(1)
        End If
    End With
    For Each item In srcWS.Range("A4", srcWS.Range("A" & Rows.Count).End(xlUp))
        Sheets("Certificate").Copy
        With ActiveSheet
            .Name = srcWS.Range("A4")
            .Range("B5") = srcWS.Range("B1")
            .Range("B6") = srcWS.Range("A4")
            .Range("B7") = srcWS.Range("B4")
            .Range("A9").Resize(lCol - 2) = WorksheetFunction.Transpose(srcWS.Range("C4").Resize(, lCol - 2))
        End With
        ActiveWorkbook.SaveAs Filename:=sPath & Application.PathSeparator & ActiveSheet.Name & "-" & item & ".xlsx", FileFormat:=51
        ActiveWorkbook.Close False
    Next item
    Application.ScreenUpdating = True
End Sub

 

[Andyg666]

Thanks, I will give it a try.