VBA/Macro to export data based on date inputs

[ForrestGump01]

Hi All,

I'm a novice VBA/Macro user, currently seeking some help with writing a dynamic macro.

I've got a process where I have to export a tab of data to a new workbook and save to a specific drive folder. OK, I've got the code for this written, and it works well (below). However, I need make the export dynamic based on whether certain columns are empty, and based on their dates...

The data is a budget reconciliation between two source tabs. In some instances we may need to reconcile past months of actual data, as well as forecast months going forward. However, historical and forecast data needs to be saved as separate files. Right now, my code saves the whole reconciliation as one file. I need to add in some code to separate the data based on if it is before the current month (say prior to July 2019) or current month and beyond (say July 2019 +). How can I add in this criteria and save as two separate exports? I'm not opposed to the criteria being tied to date "input" cells, where the user would manually identify the date ranges for each export, if this is easier than excel calculating the date ranges.

Here is my existing code:

Sub Generate_Buddie()
Dim newWB As Workbook, currentWB As Workbook
Dim newS As Worksheet, currentS As Worksheet


'Copy the data you need
Set currentWB = ThisWorkbook
Sheets("In-School Buddie").Select
Range("A:AS").Select
Selection.Copy


'Create a new file that will receive the data
Set newWB = Workbooks.Add
With newWB
Set newS = newWB.Sheets("Sheet1")
newS.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'Save in CSV
Application.DisplayAlerts = False
.SaveAs Filename:="H:\FACT Q3 - Consumer Finance Student\In-School Buddie", FileFormat:=xlCSV
Application.DisplayAlerts = True
End With



End Sub

 

[dmt32]

Hi,
You can use an Inputbox to enter the Current Month / Year and use this to Autofilter all dates in the range based on required filter Criteria (<= or > =)

Which column of your report contains the Dates?

Dave

 

[ForrestGump01]

Hi,
You can use an Inputbox to enter the Current Month / Year and use this to Autofilter all dates in the range based on required filter Criteria (<= or > =)

Which column of your report contains the Dates?

Dave

Hi Dave,

My data is in columns D:AS. Basically the structure here is columns D:I is the last six months of the prior year (e.g. always going to be historical), columns J:AS are the current year, and next two years. Obviously the last 24 columns V:AS will always be forecast periods, however, the current year columns could change (e.g. using file in July vs September would change which months of the current year are now considered historical or current/forecast).

I've redone the macro to export the file twice, and delete the excess months (e.g. historical export will delete everything in the current period, and forecast export will delete all historical columns). However, the column inputs here are fixed, and are not dynamic to consider the change of current year. This code right now spits out a historical file for last year's 6 months (columns D:I), and a forecast file with the current year and future months (columns J:AS). Now I just need to adapt the code to consider the shifting current year months...

Here's the code now:

Sub Generate_Buddie_Reports()
Dim newWB As Workbook, currentWB As Workbook
Dim newS As Worksheet, currentS As Worksheet


'Copies Data from In-School Buddie
Set currentWB = ThisWorkbook
Sheets("In-School Buddie").Select
Range("A:AS").Select
Selection.Copy


'Creates new workbook with all column data
Set newWB = Workbooks.Add
With newWB
Set newS = newWB.Sheets("Sheet1")
newS.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Range("a1").EntireRow.NumberFormat = "MMM-YY"
Columns("A:C").EntireColumn.AutoFit

'Save file as Historical Version
Application.DisplayAlerts = False
.SaveAs Filename:="H:\FACT Q3 - Consumer Finance Student\In-School Buddie Historical " & Format(Now, "MM-DD-YY")
Application.DisplayAlerts = True
End With


'Second Export
'Copy the data you need

Set shtJT = ActiveWorkbook.ActiveSheet
Range("A:AS").Select
Selection.Copy


'Create a new file that will receive the data
Set newWB = Workbooks.Add
With newWB
Set newS = newWB.Sheets("Sheet1")
newS.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'Adjust sheet (change date format, autofit columns, delete prior year months)
Range("a1").EntireRow.NumberFormat = "MMM-YY"
Columns("A:C").EntireColumn.AutoFit
Columns("D:I").EntireColumn.Delete

'Save new version as Forecast
Application.DisplayAlerts = False
.SaveAs Filename:="H:\FACT Q3 - Consumer Finance Student\In-School Buddie Forecast " & Format(Now, "MM-DD-YY")
Application.DisplayAlerts = True
ActiveWorkbook.Close SaveChanges = True
End With

'Delete Forecast months from Historical Sheet
Set shtJT = ActiveWorkbook.ActiveSheet
Columns("J:AS").EntireColumn.Delete
ActiveWorkbook.Close (SaveChanges = True)

'Return to Student Stat Account Workbook Input Sheet
Sheets("Input Sheet").Select
Range("A1").Select

End Sub

 

[dmt32]

Hi,
ok - any chance can place a copy of your workbook with sample data in a dropbox?

Dave

 

[ForrestGump01]

Hi,
ok - any chance can place a copy of your workbook with sample data in a dropbox?

Dave

I simplified and censored the file. Is there a way to insert an attachment here? My company's firewalls block cloud sites like drop-box and Google Drive. It's not a very big file in this test version, because I've deleted every tab except for the one to be exported with the macro.

 

[dmt32]

I simplified and censored the file. Is there a way to insert an attachment here? My company's firewalls block cloud sites like drop-box and Google Drive. It's not a very big file in this test version, because I've deleted every tab except for the one to be exported with the macro.

Only way is to use something like dropbox -
If work firewall causes an issue then providing you have anonymised workbook so cannot be identified with your work so as not cause any issues, then I can only suggest you upload from a home PC to dropbox or the like.

A copy of workbook just makes it easier for contributors here to figure a solution.

Dave

 

[ForrestGump01]

Only way is to use something like dropbox -
If work firewall causes an issue then providing you have anonymised workbook so cannot be identified with your work so as not cause any issues, then I can only suggest you upload from a home PC to dropbox or the like.

A copy of workbook just makes it easier for contributors here to figure a solution.

Dave

Hi Dave,

I uploaded the file to my Google drive on my phone, let me know if this link works: https://drive.google.com/file/d/1tH6zCMslxahfjN2svJzCe35j4z4-lJNI/view?usp=drivesdk

 

[dmt32]

Hi,
works ok - when I have idle moment will see if I can develop a solution (unless another here steps in) & post back


Dave

 

[ForrestGump01]

Hi,
works ok - when I have idle moment will see if I can develop a solution (unless another here steps in) & post back


Dave

Thank you Dave!

 

[dmt32]

Hi All,

I need to add in some code to separate the data based on if it is before the current month (say prior to July 2019 current month and beyond (say July 2019 +)

Hi,
based on your first post & sample data provided, see if this code helps

ensure that you copy both codes

Sub Generate_Buddie()
    Dim SearchDate As Variant
    Dim FileName As String, ReportType As Variant
    Dim CurrentMonth As String, msg As String
    Dim lc As Long
    Dim DataRange As Range, cell As Range
    Dim wsInSchoolBuddie As Worksheet
    
    Set wsInSchoolBuddie = ThisWorkbook.Worksheets("In-School Buddie")
    
    With wsInSchoolBuddie
        lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
        Set DataRange = .Cells(1, 1).Resize(.Cells(.Rows.Count, "A").End(xlUp).Row, lc)
    End With
    
    On Error Resume Next
    Do
        CurrentMonth = MonthName(Month(Date), True) & " " & Year(Date)
        SearchDate = InputBox("Enter the Month and Year" & Chr(10) & "e.g - " & CurrentMonth, "Date Entry", CurrentMonth)
'cancel pressed
        If StrPtr(SearchDate) = 0 Then Exit Sub
'get the date
        SearchDate = DateValue("01/" & SearchDate)
'report error
        If Err <> 0 Then MsgBox "Invalid Date", 48, "Invalid": Err.Clear
    Loop Until IsDate(SearchDate)
'get last day of month
    SearchDate = CLng(Application.EoMonth(SearchDate, 0))
    
    On Error GoTo myerror
    
    For Each ReportType In Array("Forecast", "Historical")
'hide all columns not in date range based on report type
    For Each cell In wsInSchoolBuddie.Cells(1, 4).Resize(, lc).Columns
        cell.EntireColumn.Hidden = Not IIf(ReportType = "Forecast", cell.Value >= SearchDate, cell.Value < SearchDate)
    Next
    
'build filename
    FileName = "In-School Buddie " & ReportType & " - " & Format(Now(), "MM-DD-YY hh mm ss")


'create report
    CreateFile DataRange, FileName
'build msg response
    msg = msg & ReportType & IIf(ReportType = "Forecast", " >= ", " < ") & Format(SearchDate, "mmm yyyy") & Chr(10)
'unhide columns
    DataRange.Columns.Hidden = False
    
    Next
    
myerror:
    With Application
        .DisplayAlerts = True: .CutCopyMode = False: .ScreenUpdating = True
    End With
    If Err > 0 Then
        MsgBox (Error(Err)), 48, "Error"
    Else
        MsgBox msg & Chr(10) & Chr(10) & "Reports Created", 48, "Reports Created"
    End If
End Sub


Sub CreateFile(ByVal Target As Range, ByVal FileName As String)
    Dim newWB As Workbook
    Dim newWS As Worksheet
    Dim FilePath As String
    
'file path to save report(s)
   FilePath = "H:\FACT Q3 - Consumer Finance Student"
   
'check path exists
    If Not Dir(FilePath, vbDirectory) = vbNullString Then
    
        With Application
           .DisplayAlerts = False: .ScreenUpdating = False
        End With
    
        Set newWB = Workbooks.Add(1)
        Set newWS = newWB.Worksheets(1)
        
        Target.SpecialCells(xlCellTypeVisible).Copy newWS.Range("A1")
    
'Save in CSV
'note:format (csv) saves only the text and values as they are displayed in cells of the copied worksheet
'formatting and data might be lost, and other features might not be supported.
        With newWB
            .SaveAs FileName:=FilePath & "\" & FileName, FileFormat:=xlCSV
            .Close False
        End With
    Else
        Err.Raise 76
    End If
End Sub

When run an InputBox will appear displaying the current Month Year. You can change this as required.

Two reports should be created

Forecast - All dates > = month year entered

Historical - All dates < month year entered

Hopefully, this is what you were looking to achieve but adjust code as required.

Dave