Separate based on months and add the entire row values from header to a new sheet.

[GirishDhruva]

Hi Everyone,

I have a huge data which i need to separate based on months and create a new sheet with the name of the month(Assume if i have date like 01-04-2019 then sheet name should be like "Apr'19") and add the entire row value including header to that sheet.

If i have more than one data for the same month then it should add the entire row in the worksheet which is already created.

Can this be done in VBA code

Billing Name	Invoice Number	Invoice Date	Client Name	Type	Service
asd	1	03-04-2019	qwe	poi	xyz
sdf	2	21-01-2020	wer	oiu	yui
dfg	3	29-04-2019	ert	iuy	abc
fgh	4	02-02-2020	rty	uyt	cde
ghj	5	18-08-2019	tyu	ytr	vgt

Regards,
Dhruva.

 

[GirishDhruva]

Ok thank you but one more thing i forgot to inform that after all the calculation and moving i need all the sheets excluding the main sheet to be saved in another new workbook with pop-up path to be asked.

Thanks in prior.

Regards,
Dhruva.

 

[mumps]

Try:

Sub CreateSheets()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object, LastRow As Long, lastRow2 As Long
    Dim ws As Worksheet, item As Variant, lDateFrom As Long, x As Long, fldr As FileDialog, selectedFolder As String
    Dim lDateTO As Long, Val As String, srcWS As Worksheet, srcWB As Workbook
    Set srcWB = ThisWorkbook
    Set srcWS = srcWB.Sheets("Sheet1")
    Set RngList = CreateObject("Scripting.Dictionary")
    LastRow = srcWS.Cells(Rows.Count, "A").End(xlUp).Row
    For Each Rng In srcWS.Range("C3:C" & LastRow)
        Val = Month(Rng) & "|" & Year(Rng)
        If Not RngList.Exists(Val) Then
            lDateFrom = DateSerial(Year(Rng), Month(Rng), 1)
            lDateTO = DateSerial(Year(Rng), Month(Rng) + 1, 0)
            Set ws = Nothing
            On Error Resume Next
            Set ws = Worksheets(Format(Rng, "mmm, yy"))
            On Error GoTo 0
            If ws Is Nothing Then
                Worksheets.Add(after:=Sheets(Sheets.Count)).Name = Format(Rng, "mmm, yy")
                srcWS.Range("A2:AC" & LastRow).AutoFilter Field:=3, Criteria1:=">=" & lDateFrom, Operator:=xlAnd, Criteria2:="<=" & lDateTO
                srcWS.Range("A1:AC" & LastRow).SpecialCells(xlCellTypeVisible).Copy Cells(1, 1)
                lastRow2 = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                Range("H" & lastRow2 + 2).Resize(, 5).Formula = "=SUM(H3:H" & lastRow2 & ")"
                Range("Q" & lastRow2 + 2).Resize(, 6).Formula = "=SUM(Q3:Q" & lastRow2 & ")"
                Cells.EntireColumn.AutoFit
            End If
        End If
    Next Rng
    If srcWS.AutoFilterMode Then srcWS.AutoFilterMode = False
    Application.Workbooks.Add (1)
    With srcWB
        For x = 2 To .Sheets.Count
            .Sheets(x).Copy after:=Sheets(Sheets.Count)
        Next x
        Application.DisplayAlerts = False
        Sheets(1).Delete
        Application.DisplayAlerts = True
    End With
    With Application.FileDialog(msoFileDialogSaveAs)
        .AllowMultiSelect = False
        If .Show = -1 Then .Execute
    End With
    Application.ScreenUpdating = True
End Sub

 

[GirishDhruva]

Thanks works perfectly

 

[mumps]

You are very welcome.