Copying data from a list into templates based on date?

Smudge.Smith · Jan 18th 2021

Hi Folks

I have a laborious task of copying data from a list (Book1) into date based templates.

What I am after is some VBA to loop through the data in Book1 and create a new file for each distinct date in the file from the master template.

This is how I see the process:

Find the beginning of the date range in Book1

Get number of rows with that date

Open template

Insert date @ D9 in

Insert count of array @ D13 ‘to give a count of rows

Insert Time array @ B20

Insert REF array @ F20

Insert value of ‘35’ @ G20 ‘for length of array

Save file named as date

Close template

Next date...ie repeat process until last date.

I have provided attachments for a visual representation

You will see that the first date in the list (colour coded in yellow) has found one row associated with the date 08/12/20 and copied the data over to the relevant cells and saved as a file named as the date ( 08DEC020)

The next date found is 17/12/2020 and so all relevant rows associated with this date (highlighted in green) are copied over to a new template which is then saved as that date (17DEC2020)... and so on for each distinct date occurrence.

The list is variable in length.

The list is sorted in date order for ease of use but may not be presented that way initially.

This seems to be a situation that Excel is crying out for to be automated via VBA (and save my typing fingers and eyesight).

Any knowledgeable people out there can help me with this?

Many thanks

Smudge

Mumps · Jan 18th 2021

I can't seem to figure out how you calculated the '35' in G20. Can you please explain? Also, do you want to save each file in the same folder as Book1? If not, what is the full path to the save folder?

Smudge.Smith · Jan 18th 2021

Hi Mumps

Thank you for the reply. The number 35 isn't a 'calculated' value as such. Its just a numerical figure that is a fixed value that needs to be in place in column G for each populated row for when the file is saved and then imported into another computer program. Because of this the structure of the template is very specific.

Also the files will exist in the same folder as Book1

Many thanks

Mumps · Jan 18th 2021

Your template sheet contains merged cells (D9 and D13). Start by unmerging those cells and delete any data in D9, D13 and in row 20 and down and then re-save it. You should avoid merging cells because they almost always cause problems for macros. Place this macro in the Book1 workbook. Change the template workbook name in the code to suit your needs as well as the sheet names.

Code

Sub FillTemplate()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, desWB As Workbook, srcWB As Workbook
    Dim dic As Object, arr As Variant, key As Variant, i As Long, cnt As Long
    Set srcWB = ThisWorkbook
    Set srcWS = srcWB.Sheets("Sheet1")
    Set desWB = Workbooks.Open(srcWB.Path & "\Template.xlsx")
    Set desWS = desWB.Sheets("Sheet1")
    Set dic = CreateObject("Scripting.Dictionary")
    With srcWS
        arr = .Range("F2", .Range("F" & .Rows.Count).End(xlUp)).Value
        For i = 1 To UBound(arr, 1)
            If Not dic.Exists(arr(i, 1)) Then
                dic.Add arr(i, 1), Nothing
            End If
        Next i
        For Each key In dic
            .Range("A1").AutoFilter 6, key
            cnt = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
            With desWS
                .Range("D9") = key
                .Range("D13") = cnt
                srcWS.Range("G2", srcWS.Range("G" & srcWS.Rows.Count).End(xlUp)).Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
                srcWS.Range("A2", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp)).Copy .Cells(.Rows.Count, "F").End(xlUp).Offset(1)
                .Cells(.Rows.Count, "G").End(xlUp).Offset(1).Resize(cnt) = 35
            End With
            With desWB
                .SaveAs Filename:=srcWB.Path & "\" & Format(CDate(key), "dd-mmm-yyyy") & ".xlsx"
                With Workbooks(Format(CDate(key), "dd-mmm-yyyy") & ".xlsx").Sheets("Sheet1")
                    .Range("D9,D13").ClearContents
                    .Range("B20", .Range("H" & .Rows.Count).End(xlUp)).ClearContents
                End With
            End With
        Next key
        srcWS.Range("A1").AutoFilter
    End With
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
End Sub

Display More

Smudge.Smith · Jan 19th 2021

Hi Mumps

Thank you so much for the time and effort you have put into this. I really appreciate it - but half way through, the VBA being run I get the dreaded VBA run-time error 1004 : Application-defined or object-defined error message.

Stepping thru the code I can see the array being formed; the code applies a filter to the headers in Book1 with nothing selected. It then opens the template and fills in the date at D9

Something then happens as D13 shows 0 where I would expect it show 1 (as there is one row that contains the date 08/12/2020...)

It then fills in B20, B21 and F20 with the header title instead of the row data... and then bombs out with the run time error 1004...

Any ideas?

Many thanks once again

Smudge.Smith · Jan 19th 2021

Almost there...but not quite.

Found that when the VBA autofilter is applied, it converts the date to American format which then seems to halt the process.

I've added Cstr (key) to the code at line 22 which converts the date to a string, which then allows it to be copied back to the relevant cell in the template.

Code

Sub FillTemplate()

Application.ScreenUpdating = False

Dim srcWS As Worksheet, desWS As Worksheet, desWB As Workbook, srcWB As Workbook
Dim dic As Object, arr As Variant, key As Variant, i As Long, cnt As Long

Set srcWB = ActiveWorkbook
Set srcWS = srcWB.Sheets("Sheet1")
Set desWB = Workbooks.Open(srcWB.Path & "\Template.xlsx")
Set desWS = desWB.Sheets("Sheet1")
Set dic = CreateObject("Scripting.Dictionary")

With srcWS
    arr = .Range("F2", .Range("F" & .Rows.Count).End(xlUp)).Value
        For i = 1 To UBound(arr, 1)
            If Not dic.Exists(arr(i, 1)) Then
                dic.Add arr(i, 1), Nothing
            End If
        Next i

        For Each key In dic
            .Range("A1").AutoFilter 6, Cstr(key)   'adding column filter to Date = the key
            cnt = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
                With desWS
                    .Range("D9") = key 'date field on template
                    .Range("D13") = cnt 'notes field on template
                    srcWS.Range("G2", srcWS.Range("G" & srcWS.Rows.Count).End(xlUp)).Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
                    srcWS.Range("A2", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp)).Copy .Cells(.Rows.Count, "F").End(xlUp).Offset(1)
                    .Cells(.Rows.Count, "G").End(xlUp).Offset(1).Resize(cnt) = 35
                End With
                
                With desWB
                    .SaveAs Filename:=srcWB.Path & "\" & format(CDate(key), "dd-mmm-yyyy") & ".xlsx"
                    With Workbooks(format(CDate(key), "dd-mmm-yyyy") & ".xlsx").Sheets("Sheet1")
                        .Range("D9,D13").ClearContents
                        .Range("B20", .Range("H" & .Rows.Count).End(xlUp)).ClearContents
                    End With
                End With
        Next key

srcWS.Range("A1").AutoFilter

End With

ActiveWorkbook.Close False
Application.ScreenUpdating = True
End Sub

Display More

All of the dated templates are produced but the placing of the data gets more and more offset as the VBA runs as the files are produced...

Mumps · Jan 19th 2021

Try:

Code

Sub FillTemplate()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, desWB As Workbook, srcWB As Workbook
    Dim dic As Object, arr As Variant, key As Variant, i As Long, cnt As Long, lRow As Long
    Set srcWB = ActiveWorkbook
    Set srcWS = srcWB.Sheets("Sheet1")
    Set desWB = Workbooks.Open(srcWB.Path & "\Template.xlsx")
    Set desWS = desWB.Sheets("Sheet1")
    Set dic = CreateObject("Scripting.Dictionary")
    With srcWS
         arr = .Range("F2", .Range("F" & .Rows.Count).End(xlUp)).Value
         For i = 1 To UBound(arr, 1)
            If Not dic.Exists(arr(i, 1)) Then
                dic.Add arr(i, 1), Nothing
            End If
         Next i
         For Each key In dic
            .Range("A1").AutoFilter 6, CStr(key) 'adding column filter to Date = the key
            cnt = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
            With desWS
                .Range("D9") = key 'date field on template
                .Range("D13") = cnt 'notes field on template
                srcWS.Range("G2", srcWS.Range("G" & srcWS.Rows.Count).End(xlUp)).Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
                srcWS.Range("A2", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp)).Copy .Cells(.Rows.Count, "F").End(xlUp).Offset(1)
                .Cells(.Rows.Count, "G").End(xlUp).Offset(1).Resize(cnt) = 35
            End With
            With desWB
                .SaveAs Filename:=srcWB.Path & "\" & Format(CDate(key), "dd-mmm-yyyy") & ".xlsx"
                With Workbooks(Format(CDate(key), "dd-mmm-yyyy") & ".xlsx").Sheets("Sheet1")
                    lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    .Range("D9,D13").ClearContents
                    .Range("B20:H" & lRow).ClearContents
                End With
            End With
         Next key
        srcWS.Range("A1").AutoFilter
    End With
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
End Sub

Display More

Smudge.Smith · Jan 19th 2021

Fantastic work. Thank you so much for this. Now works as expected.

My life just became a little easier

Mumps · Jan 19th 2021

You are very welcome.

Copying data from a list into templates based on date?

Participate now!

Share