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.

 

[Andyg666]

Hi,
I'm back (been in hospital for a while since the last post) More help is needed.
Not sure if i should of created a new post but this is linked.

I have an excel sheet and I need to copy certain cells (not all the cells in the file) across into another workbook and then save the new workbook into a folder with the filename being a combination of the cells we copied across.

I have attached an image of the two files and I have manually filled in the detail as an example of the final sheet (Plant ID, ID and Location)
This then needs to save as filename 14 ??? - Gravity valve.

there are hundreds of these i need to format so I hope to automate this.

Thanks,
Andy

 

[mumps]

It is hard to work with pictures. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach screenshots (not a pictures) of your sheets. Alternately, you could upload a copies of your files to a free site such as www.box.com or www.dropbox.com. Once you do that, mark each file for 'Sharing' and you will be given a link to each file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[Andyg666]

It is hard to work with pictures. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach screenshots (not a pictures) of your sheets. Alternately, you could upload a copies of your files to a free site such as www.box.com or www.dropbox.com. Once you do that, mark each file for 'Sharing' and you will be given a link to each file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

Yes sorry, I forgot that's how you could help me before.
The link is Data.xlsx
As you will see in the data file there are 3 tabs and there will be hundreds of rows on the actual workbook.

I have mocked up the test sheet workbook to show the data I need to copy over for each (red text)
I then need to save the new sheet with the filename being C3 & C4 & C5 & H3 each with a space in between and then I need it to repeat for the next row and all three sheets until there are no more rows with data.

Hope that makes sense.

 

[mumps]

Sheet1 in the Data file has headers in row 1. Sheets 2 and 3 do not. Is there any reason why Sheets 2 and 3 do not have any headers?

 

[Andyg666]

Sheet1 in the Data file has headers in row 1. Sheets 2 and 3 do not. Is there any reason why Sheets 2 and 3 do not have any headers?

Oh yes none of the sheets will have headers in the actual sheet. I put those in to help me while I was trying to achieve a result.

 

[mumps]

save the new workbook into a folder

Will the destination folder also contain the TEST SHEET file? If not, please post the full path to the destination folder.

 

[Andyg666]

Will the destination folder also contain the TEST SHEET file? If not, please post the full path to the destination folder.

The new sheets will be saved into a folder selected by the person using this file as there are a couple of us that will propably use this.

 

[mumps]

Before you start, you will have to either remove or replace the question marks in column A of all sheets in the Data workbook. The question mark is a reserved character so Excel will not accept it as part of a file name. Place this macro in the TEST SHEET workbook. Change the sheet name (in red) and the workbook name (in Blue) to suit your needs.

Sub CreateFiles()
    Application.ScreenUpdating = False
    Dim sPath As String, srcWB As Workbook, ws As Worksheet, desWS As Worksheet, rng As Range
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    Set srcWB = Workbooks("Data.xlsx")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a save folder bor this file (" & ActiveSheet.Name & ")."
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count > 0 Then
            sPath = .SelectedItems(1)
        End If
    End With
    For Each ws In srcWB.Sheets
        With ws
            For Each rng In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
                desWS.Range("C3") = rng
                desWS.Range("C4") = Split(rng.Offset(, 2), Chr(10))(0)
                desWS.Range("C5") = Split(rng.Offset(, 2), Chr(10))(1)
                desWS.Range("H3") = rng.Offset(, 3)
                desWS.Copy
                With desWS
                    ActiveWorkbook.SaveAs Filename:=sPath & Application.PathSeparator & _
                    .Range("C3") & " " & .Range("C4") & " " & .Range("C5") & " " & .Range("H3") & ".xlsx", FileFormat:=51
                    ActiveWorkbook.Close False
                End With
            Next rng
        End With
    Next ws
    Application.ScreenUpdating = True
End Sub