Excel VBA Sum Data within user input date range - vba

I'm trying to code a macro that will sum data based off a user-input date range. I've got the code worked out to get the user input range and verify that it is a date, as well as convert it to match the syntax of the headers in my data file, but I'm having trouble figuring out how to sum only the months within that date range, with the date range subject to change every time the macro is run.
Here is a screenshot of the workbook. If the user inputs 1/1/16 and 3/31/16, I need the "Sum of Qty" to be a sum of the qty for January, February and March 2016. The same needs to occur for "Sum of Cost." There are multiple tables on the same sheet where this needs to happen and more tables, months, and columns will continue to be added.
Here is a link to the file, if you'd like to see formatting: https://www.dropbox.com/s/bc5okk684livm3a/TestFile_DateSum.xlsx?dl=0
And here is my existing code:
Sub DateRange()
Dim dateString As String, TheDate As Date
Dim dateString2 As String, TheDate2 As Date
Dim valid As Boolean: valid = True
Dim valid2 As Boolean: valid2 = True
Do
dateString = Application.InputBox("Enter Start Date in xx/xx/xx format: ")
If IsDate(dateString) Then
TheDate = DateValue(dateString)
valid = True
Else
MsgBox "Invalid date"
valid = False
End If
Loop Until valid = True
Do
dateString2 = Application.InputBox("Enter End Date in xx/xx/xx format: ")
If IsDate(dateString2) Then
TheDate2 = DateValue(dateString2)
valid2 = True
Else
MsgBox "Invalid date"
valid2 = False
End If
Loop Until valid2 = True
Application.Calculation = xlManual
[C3] = TheDate
[C4] = TheDate2
StartMonth = Month(TheDate) & "/1/" & Year(TheDate)
EndMonth = Month(TheDate2) & "/1/" & Year(TheDate2)
'Application.Calculate
'Application.Calculation = xlAutomatic
End Sub
Any help would be greatly appreciated!

Related

How to get date value to text box from a column instead of date serial?

I created a tiny user-form where TextBox1 is txtsr and TextBox2 is txtdate. and the fourth column of my Vlookup table are Date Column, all cells are filled with date (dd-mm-yyyy) format.
With below code when I type an text in txtsr field, the txtdate is filled with date serial number instead of Date format.
Private Sub txtsr_Change()
Dim myRange As Range
Set myRange = Worksheets("VEHICLE IN").Range("B2:F20")
txtdate.Value = Application.WorksheetFunction.VLookup(txtsr, myRange, 4, False)
If Err.Number <> 0 Then txtdate.Value = ""
End Sub
how to show txtdate filled with correct date format (dd-mm-yyyy) instead of sate serial number?
This ought to do the job (untested - please try).
Private Sub txtsr_Change()
Dim myRange As Range
Dim MyDate As Variant
Set myRange = Worksheets("VEHICLE IN").Range("B2:F20")
MyDate = Application.WorksheetFunction.VLookup(txtsr, myRange, 4, False)
If Err.Number Then
txtdate.Value = ""
Else
txtdate.Value = Format(MyDate, "dd-mm-yy")
End If
End Sub

Case statement nested in WITH Statement not selecting a case

I am trying to set cell "H2" to either "Shift 1" , "Shift 2" or "Shift 3" depending on the inputted time value found in Cell D2 of my workbook, here is a screenshot example:
So Cell H2 is Shift 1 because it's within a Timevalue of Case TimeValue("11:21 PM") To TimeValue("7:20 AM")
Here is the code, it executes but doesn't select a case and I can't figure out my mistake. Also, if there is anyway to execute these 3 case statements within the With statement as I set the time input in cell "D2" inside of that with statement I would appreciate that!
.Range("D2").Value = Now 'Inputs the Time Value as the current Time
.Range("D2").NumberFormat = "h:mm:ss AM/PM" 'Formats the Time value as a Time entry
The code can be found below:
Sub ReportGeneratorTest()
Application.ScreenUpdating = False 'This speeds up the macro by hiding what the macro is doing
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Set wb3 = Workbooks.Open(Filename:="\\Report Generator\SetupSheet Report Generator.xlsm") 'Sets the Workbook variable as the database filepath
With wb3.Sheets("All Requests Sheet 1") 'With the "Changes" sheet do the following
.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 'Inserts a new row in [3] with the same format as below
.Range("A2").Value = Sheet1.Range("K112").Value 'Inputs the typed in Operator name into the Report Generator
.Range("B2").Value = Sheet1.Range("H4").Value 'Inputs the "Key" inside cell "A" of the new row
.Range("C2").Value = Now 'Inputs the Date Submitted value as the current date
.Range("C2").NumberFormat = "dd-mmm-yyyy" 'Formats the Date Submitted value as a date entry
.Range("D2").Value = Now 'Inputs the Time Value as the current Time
.Range("D2").NumberFormat = "h:mm:ss AM/PM" 'Formats the Time value as a Time entry
.Range("E2").Value = UCase(Sheet1.Range("E4").Value) 'Inputs the Part inside Cell "D" of the new row
.Range("F2").Value = Sheet1.Range("E5").Value 'Inputs the Process inside Cell "E" of the new row
.Range("G2").Value = "IRR 200-2S"
End With
Dim T1 As Date
'T1 = Range("D2").Value
T1 = Now
'Set T1 = Range("D2").Value
Select Case T1
Case TimeValue("7:21 AM") To TimeValue("3:20 PM")
Range("H2").Value = "Shift 2"
Case TimeValue("3:21 PM") To TimeValue("11:20 PM")
Range("H2").Value = "Shift 3"
Case Else 'If the Timevalue is between TimeValue("11:21 PM") To TimeValue("7:20 AM")
Range("H2").Value = "Shift 1"
End Select
wb3.Save 'Save the database Workbook
wb3.Close False
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True 'Must be "True" after running the code to be able to Read/Write the Workbook
End Sub
Summarizing the comments into an answer:
Case TimeValue("11:21 PM") To TimeValue("7:20 AM") doesn't work because when using To, the smaller value should come first. Maybe just move the "Shift 1" logic to a Case Else.
More importantly, Now includes today's date, i.e. it has both a day and time component. To get only the time component, you could do the following:
Dim T1 As Double
T1 = Now - Date

Excel VBA Chart Maximum Scale Error

Two issues with this code that I need some help on, I'm new to vba and not sure what the cause of the issues are.
First issue is that when Me.Range("L7") = Format(Me.Range("C4")....) gets formatted it puts the date in american format "mm/dd/yyyy". However, the next line Me.Range("L8") is put into the correct "dd/mm/yyyy" format?
Second issue is, when I am changing the chart maximum axis I get a type mismatch error, yet the minimum axis scale changes works perfectly fine?
Any help appreciated.
Private Sub CommandButton1_Click()
answer = MsgBox("This will prepare the workbook for the next month, are you sure?", vbYesNo)
If answer = vbNo Then Exit Sub
Range("c34") = "=DATE($B$2,$A$2,A34)" 'enters formula into cell c34
Range("a2") = Month(Date) - 1 'changes month to last month
Range("a3") = Year(Date)
If Month(Date) - 1 <> Month(Range("c34")) Then
Range("C34").Clear 'checks if last date in column is in same month, if not, clear
End If
myLR = ThisWorkbook.Sheets("Data Input").Cells(Rows.Count, 3).End(xlUp).Row 'grabs date in last row
Me.Range("L7") = Format(Me.Range("c4"), "dd/mm/yyyy") 'gets start date of month and formats it
Me.Range("L8") = Format(Me.Cells(myLR, 3).Value, "dd/mm/yyyy") 'gets last date of month and formats it
Range("K7") = "First Day of Month"
Range("K8") = "Last Day of Month"
'Chart section
Sheets("Site 5").Select
ActiveChart.ChartArea.Select
ActiveChart.Axes(xlValue).MajorGridlines.Select
ActiveChart.Axes(xlCategory).MinimumScale = Sheets("data input").Range("L7")
ActiveChart.Axes(xlCategory).MaximumScale = Sheets("data input").Range("L8")
ActiveChart.Axes(xlCategory).Select
Selection.TickLabels.NumberFormat = "d/mm/yyyy"
End Sub
It is not suitable to change cell's value by format function.
It is better to change cell's format by NumberFormatLocal.
Private Sub CommandButton1_Click()
answer = MsgBox("This will prepare the workbook for the next month, are you sure?", vbYesNo)
If answer = vbNo Then Exit Sub
Range("c34") = "=DATE($B$2,$A$2,A34)" 'enters formula into cell c34
Range("a2") = Month(Date) - 1 'changes month to last month
Range("a3") = Year(Date)
If Month(Date) - 1 <> Month(Range("c34")) Then
Range("C34").Clear 'checks if last date in column is in same month, if not, clear
End If
myLR = ThisWorkbook.Sheets("Data Input").Cells(Rows.Count, 3).End(xlUp).Row 'grabs date in last row
'Me.Range("L7") = Format(Me.Range("c4"), "dd/mm/yyyy") 'gets start date of month and formats it
Me.Range("L7") = Me.Range("c4")
Me.Range("L7").NumberFormatLocal = "dd/mm/yyyy"
'Me.Range("L8") = Format(Me.Cells(myLR, 3).Value, "dd/mm/yyyy") 'gets last date of month and formats it
Me.Range("L8") = Me.Cells(myLR, 3).Value
Me.Range("L8").NumberFormatLocal = "dd/mm/yyyy"
Range("K7") = "First Day of Month"
Range("K8") = "Last Day of Month"
'Chart section
Sheets("Site 5").Select
ActiveChart.ChartArea.Select
ActiveChart.Axes(xlValue).MajorGridlines.Select
ActiveChart.Axes(xlCategory).MinimumScale = Sheets("data input").Range("L7")
ActiveChart.Axes(xlCategory).MaximumScale = Sheets("data input").Range("L8")
ActiveChart.Axes(xlCategory).Select
Selection.TickLabels.NumberFormat = "d/mm/yyyy"
End Sub

Stuck with multiple conditions and comparing strings

I have code which creates a summary table from a bunch of excel files. The code copies and uses xlPasteSpecialOperationAdd to paste the selected range from each files to a temporary sheet.
The summary table has 2 input cells which determines the conditions. The 1st cell contains the statuses which can be [ALL, 0,1,2,3,4,5]. The 2nd field is the date in yyyy/mm/dd format.
The first cell recommended to fill, the second is optional. If the 2nd cell is empty then the date is doesn’t matter.
I think I have some trouble comparing the dates or probably the conditions incorrect. For comparing the dates I used two functions: LIKE and StrComp, but none of them worked or maybe because of the incorrect condition.
Please help me how to fix this code:
Set input cell text to string variable (2016.07 = 7 chars with dots):
'Get input date as string
AstrDate = OutputWs.Range("P5").Text
'Set the date to year and month format
AstrDateChars = Left$(strDate, 7)
Decide if the cell is blank:
'if the input range is blank then rangeBlank is true
If IsEmpty(OutputWs.Range("P5")) = True Then
rangeBlank = True
Else
rangeBlank = False
End If
'Get the output date to compare with
BstrDate = oNewBook.Sheets(1).Range("R22").Text
Get the output value:
'Set the compared date to year and month format
BstrDateChars = Left$(strDate, 7)
Comparing with StrComp function and store value into a boolean variable:
'compare date strings
'compareResult = StrComp(AstrDateChars, BstrDateChars, vbBinaryCompare)
Comparing with Like function:
compareResult = AstrDateChars Like BstrDateChars
The conditions:
'Which IL status you want to copy?
If inputValue = "ALL" And rangeBlank = True Then 'Search for all IL status
oNewBook.Worksheets(1).Range("G25:N28").Copy
tempWS.Range("G25:N28").PasteSpecial Paste:=xlPasteAll, operation:=xlPasteSpecialOperationAdd
oNewBook.Close
ElseIf inputValue = outputValue And rangeBlank = True Then 'Search for only the selected IL status
oNewBook.Worksheets(1).Range("G25:N28").Copy
tempWS.Range("G25:N28").PasteSpecial Paste:=xlPasteAll, operation:=xlPasteSpecialOperationAdd
oNewBook.Close
ElseIf inputValue = "ALL" And rangeBlank = False And compareResult = True Then 'Searcg ALL IL status and date
oNewBook.Worksheets(1).Range("G25:N28").Copy
tempWS.Range("G25:N28").PasteSpecial Paste:=xlPasteAll, operation:=xlPasteSpecialOperationAdd
oNewBook.Close
ElseIf inputValue = "ALL" And rangeBlank = False And compareResult = False Then 'Searcg ALL IL status and date, If date does not match, then closes the document
oNewBook.Close
ElseIf inputValue = outputValue And rangeBlank = False And compareResult = True Then 'Search for the selected IL0-IL5 and date
oNewBook.Worksheets(1).Range("G25:N28").Copy
tempWS.Range("G25:N28").PasteSpecial Paste:=xlPasteAll, operation:=xlPasteSpecialOperationAdd
oNewBook.Close
ElseIf inputValue = outputValue And rangeBlank = False And compareResult = False Then 'Search for the selected IL0-IL5 and date, if date does not match, then closes the document
oNewBook.Close
End If
Try this for StrComp:
compareResult = (StrComp(AstrDateChars, BstrDateChars, vbBinaryCompare)=0)

Excel VBA: add a blank cell below every output

I have a little problem with my VBA code. I use the code below to display every date in a date range. So if the date range is 3 Dec - 5 Dec, it will display 3 Dec in cell E10, 4 Dec in cell E11 and 5 Dec in cell E12. This works fine, however I need to add 4 blank cells below every date (so 3 Dec will be in cell E10, but the 4th of December will be shown in cell E15 etc).
Private Sub cmdOK_Click()
Dim RowCount As Long
Dim ctl As Control
' Check user input
If Me.SdPicker.Value = "" Then
MsgBox "Please enter an start date.", vbExclamation, "Start data error"
Me.SdPicker.SetFocus
Exit Sub
End If
If Me.EdPicker.Value = "" Then
MsgBox "Please enter the end date.", vbExclamation, "End date error"
Me.EdPicker.SetFocus
Exit Sub
End If
' Write data to worksheet
With Worksheets("Projection_Daily").Range("X1")
.Value = Me.SdPicker.Value
End With
With Worksheets("Projection_Daily").Range("Y1")
.Value = Me.EdPicker.Value
End With
' Close the form to open Output sheet and implement date range
Worksheets("Projection_Daily").Activate
Worksheets("Projection_Daily").Columns(5).ClearContents
Dim StartDate As Date
Dim EndDate As Date
Dim NoDays As Integer
StartDate = Worksheets("Projection_Daily").Range("X1").Value
EndDate = Worksheets("Projection_Daily").Range("Y1").Value
NoDays = EndDate - StartDate + 4
Worksheets("Projection_Daily").Range("E10").Value = StartDate
Worksheets("Projection_Daily").Range("E10").Resize(NoDays).DataSeries Rowcol:=xlColumns, Type:=xlChronological, Date:=xlDay, Step:=1, Stop:=EndDate, Trend:=False
Unload Me
End Sub
This is the code I currently use, I have tried to insert .Offset(4,0) to the code but with no luck. I hope you can help me with this.
Thanks!
Try using a Loop condition like this:
i = 1 'To loop through the no of days
j = 10 'To start from row no 10
For i = 1 To NoDays 'Nodays = Enddate-Startdate
Sheet1.Cells(j, 5).value = StartDate
StartDate = StartDate + 1
j = j + 5 'To add a gap of 4 blank rows
Next i