I am getting an "expected array" error on Today = Day(Today()). I have no idea what is wrong.
Dim Thisday As Integer
Dim Montho As Integer
Dim Yearo As Integer
Dim Lday As Integer
Dim last as Integer
last = Cells(Rows.Count, "A").End(xlUp).Row
Thisday = Day(date)
Montho = Month(date)
Yearo = Year(date)
Lday = Day(Application.WorksheetFunction.EoMonth(Date, -1))
Then Column B in excel gets populated with the same date, either the 15th or the last day.
If Thisday <= 15 Then
Range("B2:B" & Last).Value = Montho & "/15/" & Yearo
End If
If Thisday > 15 Then
Range("B2:B" & Last).Value = Montho & "/" & Lday & "/" & Yearo
End If
End Sub
Also not every month ends on the 30th, so how do get the Lday should return the as day of the month.
Use Date instead of Today.
Do not use the same name as functions, excel gets messed up.
vba does not have EoMonth it is part of Application.WorksheetFunction. It also returns a date or double not an integer. You will need to get the Day:
Dim Today As Integer
Dim Montho As Integer
Dim Yearo As Integer
Dim Lday As Integer
Dim last As Integer
last = Cells(Rows.Count, "A").End(xlUp).Row
Today = Day(Date)
Montho = Month(Date)
Yearo = Year(Date)
Lday = Day(Application.WorksheetFunction.EoMonth(Date, 0))
If Today <= 15 Then
Range("B2:B" & Last).Value = Montho & "/15/" & Yearo
End If
If Today > 15 Then
Range("B2:B" & Last).Value = Montho & "/" & Lday & "/" & Yearo
End If
The above code returns a string that looks like a date. To return a true date use this:
Dim Today As Integer
Dim Montho As Integer
Dim Yearo As Integer
Dim last As Integer
last = Cells(Rows.Count, "A").End(xlUp).Row
Today = Day(Date)
Montho = Month(Date)
Yearo = Year(Date)
Range("B2:B" & Last).NumberFormat = "mm/dd/yyyy"
If Today <= 15 Then
Range("B2:B" & Last).Value = DateSerial(Yearo, Montho, 15)
End If
If Today > 15 Then
Range("B2:B" & 4).Value = Application.WorksheetFunction.EoMonth(Date, 0)
End If
Try,
Range("B2:B" & Last).Value = dateserial(year(date), month(date)-(day(date)>15), 15 * abs(day(date)<=15))
Related
I have a file I want to pickup from the previous wednesday June 10th. I will be running my code today (Sunday June 14th). However this will reoccur every week.
Is there a way I can make my code dynamic enough to pickup the previous wednesday date?
Here is my code Set wbTarget = Workbooks.Open("C:\extract\Business_Report_20200527.xlsx")
Can I alter that path to dynamically pickup a date?
Thank you.
Try this:
Dim today As Date
Dim IntervalType As String
Dim FilePath As String
today = Date()
IntervalType = "d"
While Weekday(today) <> vbWednesday
today = DateAdd(IntervalType, -1, today)
Wend
FilePath = "C:\extract\Business_Report_" + Format(today, "yyyymmdd") + ".xlsx"
Set wbTarget = Workbooks.Open(FilePath)
Another way to do it:
Sub Test()
MsgBox "Last Wednesday: " & PreviousWednesday & vbCr & _
"Wednesday prior to 9th June: " & PreviousWednesday(DateValue("9 June 2020")) & vbCr & _
"Last Wednesday formatted: " & Format(PreviousWednesday, "yyyymmdd")
'Your code:
'Set wbTarget = Workbooks.Open("C:\extract\Business_Report_" & Format(PreviousWednesday, "yyyymmdd") & ".xlsx")
End Sub
Public Function PreviousWednesday(Optional CurrentDate As Date) As Date
If CurrentDate = 0 Then CurrentDate = Date
PreviousWednesday = (CurrentDate - Weekday(CurrentDate, vbMonday) + 1) - 5
End Function
I have an excel vba sub that sends email reminders every 14 days based on a date in a cell. I would also like to include the week number since the date in the cell to todays date. E.g. Cell date 1st April to present day 28th April to return 4 weeks. Please can someone help.
Sub SalesProgress14()
'
' 14 Day Sales Chase Loop
'
'Dim Answer As VbMsgBoxResult
'Answer = MsgBox("Are you sure you want to run?", vbYesNo, "Run Macro")
'If Answer = vbYes Then
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
Dim saledate As String
Set Mail_Object = CreateObject("Outlook.Application")
For i = 2 To lr
With Mail_Object.CreateItem(o)
.Subject = "Sales Chase" & Range("S" & i).Value & " " & Range("U" & i).Value & " " & Range("G" & i).Value
.To = "test#test.com"
.Body = Range("S" & i).Value & " " & Range("U" & i).Value & " " & Range("G" & i).Value
'.display
' Our data below
saledate = Range("F" & i).Value
' Send logic
If DateDiff("d", saledate, Date) Mod 14 = 0 Then .Send
If saledate = Date - 7 Then .Send
End With
Next i
'MsgBox "E-mails successfully sent", 64
'Application.DisplayAlerts = False
Set Mail_Object = Nothing
' The End If below relates to the run yes or no box
'End If
End Sub
use
DateDiff("w", saledate, Date)
You could use ISOWEEKNUM
Public Sub Test()
Dim saleDate As Date, currDate As Date
saleDate = "2018-04-01"
currDate = "2018-04-28"
Debug.Print Application.WorksheetFunction.IsoWeekNum(currDate) - Application.WorksheetFunction.IsoWeekNum(saleDate)
End Sub
I have an issue with the following code for some reason when creating the files it only goes the 30th not the 31st on the correct months and in February it creates up to the 30th. The code is designed to create folder for each month then create a months worth of files from 1 master document. The original code I used worked but did not create the folders.
This is the code returning the error
Sub Folder()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
'Dim fso As FileSystemObject ' ''early binding. Requires reference to MS Scripting runtime
'Set fso = New FileSystemObject ''early binding
Dim myYear As Long
Dim endOfMonth As Long
Dim filePathStub As String
filePathStub = "c:\user\test briefing sheet\2019\" ' path to create folders at"
myYear = 19
Dim monthsArray() As Variant
monthsArray = Array("Jan", "Feb", "Mar", "April", "May", "Jun", "Jul", "Aug", "Sept", "Oct", "Nov", "Dec")
Dim currentMonth As Long
For currentMonth = LBound(monthsArray) To UBound(monthsArray)
Dim folderName As String
folderName = monthsArray(currentMonth) & " " & CStr(myYear)
folderName = fso.CreateFolder(folderName)
endOfMonth = CLng(Format$(dhLastDayInMonth(DateSerial(myYear, currentMonth + 1, 0)), "dd"))
Dim currentDay As Long
For currentDay = 1 To endOfMonth
ActiveDocument.SaveAs2 FileName:=folderName & Application.PathSeparator & monthsArray(currentMonth) & " " & currentDay, FileFormat:=wdFormatXMLDocument
Next currentDay
Next currentMonth
End Sub
Function dhLastDayInMonth(Optional dtmDate As Date = 0) As Date
' Return the last day in the specified month.
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhLastDayInMonth = DateSerial(Year(dtmDate), _
Month(dtmDate) + 1, 0)
End Function
This was the original code
Sub Mine()
Dim DateStr, FileStr As String
DateStr = Format$(Date, "DD")
FileStr = DateStr & ".docx"
ActiveDocument.Save
ChangeFileOpenDirectory "c:\user\test briefing sheet\2019\"
ActiveDocument.SaveAs2 FileName:=FileStr, FileFormat:=wdFormatXMLDocument
End Sub
Any ideas?
In this line:
ActiveDocument.SaveAs2 FileName:=folderName & Application.PathSeparator & monthsArray(currentMonth) & " " & currentDay, FileFormat:=wdFormatXMLDocument
currentDay is Long, while you are trying to use it as string. I'd code it as follows:
Dim documentName as string
documentName = monthsArray(currentMonth) & " " & CStr(currentDay)
ActiveDocument.SaveAs2 FileName:=folderName & Application.PathSeparator & documentName, FileFormat:=wdFormatXMLDocument
Also, I'd re-write this line:
endOfMonth = CLng(Format$(dhLastDayInMonth(DateSerial(myYear, currentMonth + 1, 0)), "dd"))
as:
endOfMonth = DAY(dhLastDayInMonth(DateSerial(myYear, currentMonth + 1, 0)))
I feel like this should be possible with less lines. Am I missing a VBA function to make this easier?
Sub dates()
Dim sDay As String
Dim eday As String
Quarter = DatePart(q, Date)
If Quarter = 1 Then
sDay = "1/1/" & DatePart("yyyy", Date)
eday = "3/31/" & DatePart("yyyy", Date)
ElseIf Quarter = 2 Then
sDay = "4/1/" & DatePart("yyyy", Date)
eday = "6/30/" & DatePart("yyyy", Date)
ElseIf Quarter = 3 Then
sDay = "7/1/" & DatePart("yyyy", Date)
eday = "9/30/" & DatePart("yyyy", Date)
ElseIf Quarter = 4 Then
sDay = "10/1/" & DatePart("yyyy", Date)
eday = "12/31/" & DatePart("yyyy", Date)
End If
End Sub
Yep:
Sub dates()
Dim sDay As String
Dim eDay As String
Dim Quarter As Integer
For Quarter = 1 To 4
sDay = CStr(3 * (Quarter - 1) + 1) & "/1/" & DatePart("yyyy", Date)
eDay = DateAdd("d", -1, DateAdd("q", 1, CDate(sDay)))
Debug.Print "Quarter : " & Quarter & vbTab & sDay & vbTab & eDay
Next
End Sub
Also note that in your code, q needs to be offset in double-quotes as a string literal, unless it is defined elsewhere as such.
Quarter = DatePart("q", Date)
Sub Qmonth()
Dim CMonth As Integer 'selected month from range
Dim CYear As Integer 'selected year from range
CMonth = Range("MonthO").Value
CYear = Range("YearO").Value
Select Case CMonth
Case 1 To 3
Debug.Print DateSerial(CYear, 1, 1)
Case 4 To 6
Debug.Print DateSerial(CYear, 4, 1)
Case 7 To 9
Debug.Print DateSerial(CYear, 7, 1)
Case 10 To 12
Debug.Print DateSerial(CYear, 10, 1)
End Select
End Sub
Can someone please help me to fix the formula in the sub. I need to enter dates into it via variables but it always gives me an error '13' data types
I'm talking about the bit:
Cells(5, field).FormulaLocal = "=SUMMEWENNS(Rawdata!K2:K3446;Rawdata!I2:I3446;""bezahlt"";Rawdata!A2:A3446;" >= " & weekstart & "";Rawdata!A2:A3446;" <= " & weekend & "")"
The Sub apart from that formula works.....
Sub get_cal_weeks()
Dim weeks As Integer, i As Integer, col As String, weekstart As Date, weekend As Date, calweeks() As Variant
'start column is D
col = "D"
'get amount of weeks
weeks = countcalweeks()
'populate array calweeks
calweeks = fillcalweeks(weeks)
For i = 0 To weeks
field = i + i + 4
weekstart = calweeks(i, 0)
weekend = calweeks(i, 1)
Cells(5, field).FormulaLocal = "=SUMMEWENNS(Rawdata!K2:K3446;Rawdata!I2:I3446;""bezahlt"";Rawdata!A2:A3446;" >= " & weekstart & "";Rawdata!A2:A3446;" <= " & weekend & "")"
Next
End Sub
Thank you
I suggest you convert to long (or double if you need times)
Cells(5, field).FormulaLocal = "=SUMMEWENNS(Rawdata!K2:K3446;Rawdata!I2:I3446;""bezahlt"";Rawdata!A2:A3446;"">=" & CLng(weekstart) & """;Rawdata!A2:A3446;""<=" & CLng(weekend) & """)"