Macro to split worksheet by date

[Chunky_22]

Hi All

I have a fairly large sheet sorted by date. The earliest date is 01/04/2010 (01 April). The dates appear in column G. Rows 1 - 5 are header rows, so the first line of data is row 6.

I need to create multiple workbooks, one for each month that have the 5 header rows at the top, and then all the data for that month. I also need the file to be saved automatically to a location on my computer, including the Month and year in the file name.

My current data range (under the header rows is A6:AF8102 but this could change for future files.

Could someone assist with this please? It would be a great help.

Thanks in advance

 

[AlphaFrog]

Sub Save_Data_by_Month()

    Dim ws As Worksheet, wb As Workbook
    Dim MinDate As Date, MaxDate As Date
    Dim StartDate As Date, EndDate As Date
    Dim i As Long
    Dim SavePath As String
    
    [COLOR="Red"]SavePath = "C:\Temp\"[/COLOR]
    Set ws = ActiveWorkbook.ActiveSheet
    Lastrow = ws.Range("G" & Rows.Count).End(xlUp).Row
    MinDate = Application.WorksheetFunction.Min(ws.Range("G6:G" & Lastrow))
    MaxDate = Application.WorksheetFunction.Max(ws.Range("G6:G" & Lastrow))
    
    Application.ScreenUpdating = False
    
    Workbooks.Add
    Set wb = ActiveWorkbook
    wb.Sheets(1).Name = ws.Name
    
    For i = 0 To DateDiff("m", MinDate, MaxDate)
    
        StartDate = DateSerial(Year(MinDate), Month(MinDate) + i, 1)
        EndDate = DateSerial(Year(MinDate), Month(MinDate) + i + 1, 0)
        
        ws.Range("G5:G" & Lastrow).AutoFilter _
                                   Field:=1, _
                                   Criteria1:=">=" & StartDate, _
                                   Operator:=xlAnd, _
                                   Criteria2:="<=" & EndDate
                                   
        If ws.Range("G" & Rows.Count).End(xlUp).Row > 5 Then
            ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy
            wb.Sheets(1).Paste
            wb.Sheets(1).Range("A1").Select
            wb.SaveAs SavePath & Format(StartDate, "mmmm yyyy") & ".xls"
            wb.Sheets(1).UsedRange.ClearContents
        End If
        
    Next i
    
    wb.Close SaveChanges:=False
    ws.AutoFilterMode = False
    Application.ScreenUpdating = True
    MsgBox "Data has been filtered and saved by Month.", vbInformation, "Data Save Complete"
    
End Sub

 

[Chunky_22]

Hi

Thanks for that. I have updated the code with my save location, but the files dont appear there.

I get the message saying files are sorted and saved, but they are not in my save location. I have tried several locations

 

[AlphaFrog]

If you have Excel 2007 or later, you may want to change this

wb.SaveAs SavePath & Format(StartDate, "mmmm yyyy") & ".xls"

To this...

wb.SaveAs SavePath & Format(StartDate, "mmmm yyyy") & ".xls[COLOR="Red"]x[/COLOR]"

Are the dates in column G serial dates that Excel recognizes as a date or are they text that "look" like a Date? If they are just text, then you'll have to covert then to actual dates that Excel recognizes as a date.

If you can change the cell format of column G to "Number" and see the dates as integers, then the dates are serial dates (good). If you change the cell format of column G to "Number" and still see text dates then you'll have to convert the text to dates using the Text to Columns feature.

 

[Chunky_22]

Hi Mate

Im on Excel 2010. I changed the line to include .xlsx as you said. The dates are actual dates (01/04/2010 shows as 40269 if I change the format to number).

It still doesnt work though. It's weird though, because I dont get any error messages.

 

[AlphaFrog]

Run this as a test and tell me what the message box says.

Sub Diagnostic1()

    Dim ws As Worksheet
    Dim MinDate As Date, MaxDate As Date

    Set ws = ActiveSheet
    Lastrow = ws.Range("G" & Rows.Count).End(xlUp).Row
    MinDate = Application.WorksheetFunction.Min(ws.Range("G6:G" & Lastrow))
    MaxDate = Application.WorksheetFunction.Max(ws.Range("G6:G" & Lastrow))
    

    MsgBox "MinDate = " & MinDate & vbCr & _
           "MaxDate = " & MaxDate & vbCr & _
           "Date range = " & ws.Range("G6:G" & Lastrow).Address, , "Diag1"
    
End Sub

 

[Chunky_22]

When I step through the process, it gets to here:

If ws.Range("G" & Rows.Count).End(xlUp).Row > 5 Then
ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy
wb.Sheets(1).Paste
wb.Sheets(1).Range("A1").Select
wb.SaveAs SavePath & Format(StartDate, "mmmm yyyy") & ".xlsx"
wb.Sheets(1).UsedRange.ClearContents
End If

Next i

it jumps from the first line straight to the End If, onto the Next i, then goes through it again. I dont fully understand this, but it looks as though no data satisfies the IF statement on the first line?

 

[Chunky_22]

Run this as a test and tell me what the message box says.

Sub Diagnostic1()

    Dim ws As Worksheet
    Dim MinDate As Date, MaxDate As Date

    Set ws = ActiveSheet
    Lastrow = ws.Range("G" & Rows.Count).End(xlUp).Row
    MinDate = Application.WorksheetFunction.Min(ws.Range("G6:G" & Lastrow))
    MaxDate = Application.WorksheetFunction.Max(ws.Range("G6:G" & Lastrow))
    

    MsgBox "MinDate = " & MinDate & vbCr & _
           "MaxDate = " & MaxDate & vbCr & _
           "Date range = " & ws.Range("G6:G" & Lastrow).Address, , "Diag1"
    
End Sub

It says:

MinDate = 1/04/2010
MaxDate = 31/03/2011
Date range = $G$6:$G$8102

 

[AlphaFrog]

For i = 0 To DateDiff("m", MinDate, MaxDate)

Loops through each month from the minimum date to the maximum date

 StartDate = DateSerial(Year(MinDate), Month(MinDate) + i, 1)
EndDate = DateSerial(Year(MinDate), Month(MinDate) + i + 1, 0)

Sets the filter criteria dates to the 1st date of a given month and the last date of a given month e.g. the 1st month would be
StartDate = 1/4/2010
EndDate = 30/4/2010

        ws.Range("G5:G" & Lastrow).AutoFilter _
                                   Field:=1, _
                                   Criteria1:=">=" & StartDate, _
                                   Operator:=xlAnd, _
                                   Criteria2:="<=" & EndDate

Autofilters column G for all date between StartDate and EndDate
If you comment out the line
Application.ScreenUpdating = False
...you should see the filtered data on the worksheet as you step through the code

If ws.Range("G" & Rows.Count).End(xlUp).Row > 5 Then

After filtering the dates for a given month, this IF line tests if there is any result dates visible in column G by testing if the last visible cell in column G has a row number greater than 5
I don't know why there isn't any filtered dates between the 1st day of a given month and the last day of a given month.???

 

[Chunky_22]

OK, with the screen updating commented out, it appears that a new workbook is added by Workbooks.Add

The rest of the code then seems to run on the new workbook (which is blank). It loks like it needs to be told to add a workbook, and then after it has named the sheets it needs to switch back to the original worksheet?