Generating multiple sheets from a sheet based on 2 dates

[pranavshandilya]

I have a sheet "data-dump", which has data from row 2 (column A to D) onwards where row 2 has got headers. The first 2 columns of the sheet has Start-Date & End-Date. I need to create a macro such that it reads the data in the sheet "data-dump" and based on the column A & B i.e. Start-Date & End-Date, creates multiple sheets for the dates.
for example if I have below data in data-dump sheet, it should create 3 sheets viz. 01-Sep-2021, 02-Sep-2021 and 03-Sep-2021, in which

• 01-Sep-2021: should have 2 records Task Description 1 & 3
• 02-Sep-2021: should have 3 records Task Description 1, 2 & 3
• 03-Sep-2021: should have 1 records Task Description 1

PS: the number of sheet to be created is determined by min value of Start date and max value of End-Date.

Any help would be greatly appreciated.
Thanks

Start-Date	End-Date	Task	Program
01/09/2021	03/09/2021	Task Description 1	VBA
02/09/2021	02/09/2021	Task Description 2	Java
01/09/2021	02/09/2021	Task Description 3	SAP

 

[DanteAmor]

I have some doubts:

In the following scenario, the sheets 4Sep and 5Sep and 7sep must also be created or only 1,2,3, 6 and 8 Sep.

varios 23sep2021.xlsm
	A	B	C	D
1
2	Start-Date	End-Date	Task	Program
3	01/09/2021	03/09/2021	Task Description 1	VBA
4	02/09/2021	02/09/2021	Task Description 2	Java
5	01/09/2021	02/09/2021	Task Description 3	SAP
6	06/09/2021	08/09/2021	Task Description 4	Excel
data-dump

What columns do you want on each new sheet? do you want all 4 columns? With headers?

 

[pranavshandilya]

HI DanteAmor,

Thanks for the response.

Yes, based on the above data all the dates from 1-Sep through to 8-Sep should be created. with sheet 4-Sep and 5-Sep not having any records just headers.
All the columns need to be copied.

Basic idea is to split the data with respect to dates showing all the tasks relevant for that date.

Thanks

 

[DanteAmor]

Try this:

Sub GeneratingSheets()
  Dim dic As Object
  Dim sh As Worksheet
  Dim a As Variant, ky As Variant
  Dim i As Long, lr As Long, nmin As Long, nmax As Long
  
  Application.ScreenUpdating = False
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh = Sheets("data-dump")
  lr = sh.Range("A" & Rows.Count).End(3)
  a = sh.Range("A3:D" & lr).Value
  
  nmin = WorksheetFunction.Min(sh.Range("A3:A" & lr))
  nmax = WorksheetFunction.Max(sh.Range("B3:B" & lr))
  For i = nmin To nmax
    dic(i) = 3
    Sheets.Add(, Sheets(Sheets.Count)).Name = Format(i, "dd-mmm-yyyy")
    Sheets(Format(i, "dd-mmm-yyyy")).Range("A2:D2").Value = sh.Range("A2:D2").Value
  Next
  
  For Each ky In dic.keys
    For i = 1 To UBound(a, 1)
      If ky >= a(i, 1) And ky <= a(i, 2) Then
        Sheets(Format(ky, "dd-mmm-yyyy")).Range("A" & dic(ky)).Resize(1, 4).Value = Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4))
        dic(ky) = dic(ky) + 1
      End If
    Next
  Next
End Sub

 

[Marc L]

According to post #2 attachment an easy VBA demonstration for starters :​

Sub Demo1()
        Dim L&, S$
    With ['data-dump'!A2].CurrentRegion
            If .Rows.Count = 1 Then Beep: Exit Sub
            Application.ScreenUpdating = False
           .Range("K2").Formula = "=AND(L$3>=A3,L$3<=B3)"
        For L = Application.Min(.Columns(1)) To Application.Max(.Columns(2))
            S = Format$(L, "dd-mmm-yyyy")
            If Evaluate("ISREF('" & S & "'!A1)") Then Sheets(S).UsedRange.Clear Else Sheets.Add(, Sheets(Sheets.Count)).Name = S
           .Range("L2").Value2 = L
           .AdvancedFilter 2, .Range("K1:K2"), Sheets(S).[A1]
        Next
           .Range("K2:L2").Clear
    End With
            Application.ScreenUpdating = True
End Sub

 

[pranavshandilya]

Apologies for the late response.

Thank you DanteAmor & Marc L.

Both of your solutions work for me. Thanks for your help here.

Cheers
P

 

[DanteAmor]

Glad we could help & thanks for the feedback