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.

 

[salmabanu]

I have uploaded the data file and template in the dropbox and below are the links

Data.xlsx

Shared with Dropbox

www.dropbox.com

Template.xlsx

Shared with Dropbox

www.dropbox.com

 

[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("B" & .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("B" & .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]

It's still the same it's not copying the unique rows. I have uploaded the files it created after running the macro. Its retaining all the data from all unique ids.

Below is the dropbox link.

Test-Files

Shared with Dropbox

www.dropbox.com

 

[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
    For Each key In RngList
        With desWB
            .Sheets(1).UsedRange.Offset(4).ClearContents
            .Sheets(2).UsedRange.Offset(4).ClearContents
        End With
        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("B" & .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("B" & .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]

A huge thank you for helping me out here. The code is working perfectly fine now. Thanks again

 

[mumps]

My pleasure.