Copy the data into template for each unique value of a row

[salmabanu]

HI,

I have a standard template of two worksheets and i have a data file with unique id in column "A" and data related to that in column "B" and "C". What i want to achieve is for each unique id i want to copy the rows from data file of column "B" to Sheet1 of template, and column "C" to sheet2 of template and save that template with unique id name found in data file.

I have attached the images of data file and template.

This is little urgent any help around this would be appreciated.

 

[mumps]

Are the two files already saved in the same folder? Do you want to save the new files in that folder? If not, what is the full path to the destination folder?

 

[salmabanu]

Yes both the files are stored in the same folder. i want to save the new files in new folder. It can create a new folder inside the folder where data file and template is stored.

 

[mumps]

Will the unique ID in the Data file be a number as in your attached image?

 

[salmabanu]

No it will be alphanumeric.

 

[mumps]

Manually create a new sub folder in the folder containing the two files. Place the macro below in the Data file. Change the sheet name (in red), the workbook name (in blue) and the new folder name (in orange) to suit your needs.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim rng As Range, srcWS As Worksheet, desWB As Workbook, RngList As Object, key As Variant
    Set srcWS = ThisWorkbook.Sheets("Data")
    Set desWB = Workbooks("Template.xlsx")
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each rng In srcWS.Range("A2", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp))
        If Not RngList.Exists(rng.Value) Then
            RngList.Add rng.Value, Nothing
        End If
    Next
    For Each key In RngList
        With srcWS
            .Cells(1).CurrentRegion.AutoFilter 1, key
            .Range("B2", .Range("B" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy desWB.Sheets(1).Cells(desWB.Sheets(1).Rows.Count, "B").End(xlUp).Offset(1)
            .Range("C2", .Range("C" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy desWB.Sheets(2).Cells(desWB.Sheets(2).Rows.Count, "B").End(xlUp).Offset(1)
            desWB.SaveAs ThisWorkbook.Path & "\" & "Test" & "\" & key & ".xlsx"
        End With
    Next key
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[salmabanu]

Manually create a new sub folder in the folder containing the two files. Place the macro below in the Data file. Change the sheet name (in red), the workbook name (in blue) and the new folder name (in orange) to suit your needs.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim rng As Range, srcWS As Worksheet, desWB As Workbook, RngList As Object, key As Variant
    Set srcWS = ThisWorkbook.Sheets("Data")
    Set desWB = Workbooks("Template.xlsx")
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each rng In srcWS.Range("A2", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp))
        If Not RngList.Exists(rng.Value) Then
            RngList.Add rng.Value, Nothing
        End If
    Next
    For Each key In RngList
        With srcWS
            .Cells(1).CurrentRegion.AutoFilter 1, key
            .Range("B2", .Range("B" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy desWB.Sheets(1).Cells(desWB.Sheets(1).Rows.Count, "B").End(xlUp).Offset(1)
            .Range("C2", .Range("C" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy desWB.Sheets(2).Cells(desWB.Sheets(2).Rows.Count, "B").End(xlUp).Offset(1)
            desWB.SaveAs ThisWorkbook.Path & "\" & "Test" & "\" & key & ".xlsx"
        End With
    Next key
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Manually create a new sub folder in the folder containing the two files. Place the macro below in the Data file. Change the sheet name (in red), the workbook name (in blue) and the new folder name (in orange) to suit your needs.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim rng As Range, srcWS As Worksheet, desWB As Workbook, RngList As Object, key As Variant
    Set srcWS = ThisWorkbook.Sheets("Data")
    Set desWB = Workbooks("Template.xlsx")
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each rng In srcWS.Range("A2", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp))
        If Not RngList.Exists(rng.Value) Then
            RngList.Add rng.Value, Nothing
        End If
    Next
    For Each key In RngList
        With srcWS
            .Cells(1).CurrentRegion.AutoFilter 1, key
            .Range("B2", .Range("B" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy desWB.Sheets(1).Cells(desWB.Sheets(1).Rows.Count, "B").End(xlUp).Offset(1)
            .Range("C2", .Range("C" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy desWB.Sheets(2).Cells(desWB.Sheets(2).Rows.Count, "B").End(xlUp).Offset(1)
            desWB.SaveAs ThisWorkbook.Path & "\" & "Test" & "\" & key & ".xlsx"
        End With
    Next key
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Hello Mumps,

Thank you so much for the code. I was able to create individual files but i see that its copying the file 1 data as well in file 2 similar with all files. How do we ensure that only filtered data is copied in each individual file. Also can you please help to exclude blank rows and copy the data as paste special values.

Much appreciate the help and support received so far. You have been very helpful.

Thanks,
Salma

 

[mumps]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim lastRow As Long, rng As Range, srcWS As Worksheet, desWB As Workbook, RngList As Object, key As Variant
    Set srcWS = ThisWorkbook.Sheets("Data")
    Set desWB = Workbooks("Template.xlsx")
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each rng In srcWS.Range("A2", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp))
        If rng <> "" And Not RngList.Exists(rng.Value) Then
            RngList.Add rng.Value, Nothing
        End If
    Next
    With desWB
        .Sheets(1).UsedRange.Offset(4).ClearContents
        .Sheets(2).UsedRange.Offset(4).ClearContents
    End With
    For Each key In RngList
        With srcWS
            lastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Range("A1:C" & lastRow).AutoFilter Field:=1, Criteria1:=key
            .Range("B2", .Range("B" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
            With desWB.Sheets(1)
                lastRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                .Cells(lastRow, 2).PasteSpecial xlPasteValues
                On Error Resume Next
                .Range("B5", .Range("B" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                On Error GoTo 0
            End With
            .Range("C2", .Range("C" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
            With desWB.Sheets(2)
                lastRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                .Cells(lastRow, 2).PasteSpecial xlPasteValues
                On Error Resume Next
                .Range("B5", .Range("B" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                On Error GoTo 0
            End With
            Application.DisplayAlerts = False
            desWB.SaveAs ThisWorkbook.Path & "\" & "Test" & "\" & key & ".xlsx"
            Application.DisplayAlerts = True
        End With
    Next key
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[salmabanu]

Sorry to say mump this is still not working. it's still copying the second file data now in each files. Also even after specifying to copy the data on B5 of template its still copying the data to B2 of template file

 

[mumps]

Use the XL2BB add-in (icon is in the menu) to attach a screenshot of the Data file and Template file. Alternately, you could upload a copy 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 the files that you can post here. If the workbook contains confidential information, you could replace it with generic data.