What am I doing wrong ?
in cell a2 I have a date (US) format 19790131. I would like to have this rewritten in 31.01.1979 enter code hereBut get the result: 1/31/1979
For i = 2 To z
DatText = Cells(i, x)
Cells(i, x) = CDate(Mid(DatText, 7, 2) & "." & Mid(DatText, 5, 2) & "." & Mid(DatText, 1, 4))
Cells(i, x).NumberFormat = "dd.mm.yyyy"
Next i
Use slashes instead of periods so CDate will understand it.
Cells(i, x) = CDate(Mid(DatText, 7, 2) & "/" & Mid(DatText, 5, 2) & "/" & Mid(DatText, 1, 4))
If the date is a "real" Excel date, with a cell format of "yyyymmdd", then you just need to change the cell format to "dd.mm.yyy"
If the date is the actual number: 19790131, then you have to convert it first to a real date. Try:
Function dtNumToDt(n As Long) As Date
Dim yr As Long, mn As Long, dy As Long
yr = Left(n, 4)
mn = Mid(n, 5, 2)
dy = Right(n, 2)
dtNumToDt = DateSerial(yr, mn, dy)
End Function
And then format the cell (numberformat) as "dd.mm.yyy"
You can use Format for this - and include IsDate for a little error handling:
Public Function ConvertDate()
Dim ThisCell As Excel.Range
Dim RowIndex As Long
Dim ColumnIndex As Long
Dim DatText As String
ColumnIndex = 1
For RowIndex = 2 To 10
Set ThisCell = Cells(RowIndex, ColumnIndex)
If Not IsDate(ThisCell.Value) Then
DatText = Format(ThisCell.Value, "####\/##\/##")
If IsDate(DatText) Then
ThisCell.Value = CDate(DatText)
End If
End If
Next
End Function
Related
I am trying to add to add French version to my code. I have macro that reads from text file report and extracts dates in correct format. Text file date format is JUL13/2023. My macro works just fine but sometimes dates appear in French - JAN - January, F:V – February, MAR - March, AVR - April, MAI- May, JUN - June, JLT - July, AO} – August, SEP – September, OCT – October, NOV - November, D:C – December. I am trying to find the best solution to add it into my code so it can read all possible dates and give me just regular date format as an output. Here is my code:
Sub test()
Dim fn As String, mtch As Object, m As Object, s As Object, txt As String
Dim i As Long
fn = "C:\temp\test.txt"
txt =CreateObject("scripting.filesystemobject").OpenTextFile(fn).ReadAll
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "[^\n]+"
Set mtch = .Execute(txt)
i = 1
Dim b As Long
b = 1
For Each m In mtch
.Pattern = "[a-zA-Z0-9]{7}\s\s[^\s]+\s[a-zA-Z\s]*[0-9]{2}\/[0-9]{4}"
For Each s In .Execute(m.Value)
i = i + 1
Cells(i, 1) = s
b = b + 1
Range("B" & b).Value = Right(Cells(i, 1), 10)
Next
Next
End With
Dim var As String
Dim N As Long, p As Long, j As Long
N = Cells(Rows.Count, "B").End(xlUp).Row
For p = 2 To N
var = Range("B" & p).Value
Range("C" & p).Value = convert_date(var)
Range("D" & p).Value = Range("C" & p) + 179
Range("E" & p).Value = Range("C" & p) + 209
j = j + 1
Next p
End Sub
Function convert_date(date_as_string As String) As Date
Dim mthstring As String
mthstring = "JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC"
convert_date = DateSerial( _
CInt(Right(date_as_string, 4)), _
CInt(((InStr(1, mthstring, Left(date_as_string, 3)) - 1) / 4) + 1), _
CInt(Replace(Mid(date_as_string, 4, 2), "/", "")))
End Function
Sub testConvertDate()
Dim var As String
Dim N As Long, i As Long, j As Long
N = Cells(Rows.Count, "B").End(xlUp).Row
Dim m As Integer
For i = 2 To N
'Range("B" & i).Value = Right("A" & i, 10)
var = Range("B" & i).Value
Range("C" & i).Value = convert_date(var)
Range("D" & i).Value = Range("C" & i) + 179
Range("E" & i).Value = Range("C" & i) + 209
j = j + 1
Next i
End Sub
And here is my outcome:
Because of the fact that your French months name enumeration contains strings of 3 or 4 characters, you need to process the string Date in a different way. Please, try the next adapted function. Do not miss to also copy the function returning only numbers (onlyNo):
Function convert_date(date_as_string As String) As Date
Dim mthstring As String, strLeft As String, arrD, dayNo As Long, monthNo As Long, y As Long
mthstring = "JANV,FEVR,MARS,AVRIL,MAI,JUIN,JUIL,AOUT,SEPT,OCT,NOV,DEC"
arrD = Split(mthstring, ",") 'place the string in an array
y = CLng(Split(date_as_string, "/")(1)) 'extract the year
strLeft = Split(date_as_string, "/")(0) 'extract the left string Date split by "/"
dayNo = onlyNo(strLeft) 'extract the day number
monthNo = Application.match(left(strLeft, Len(strLeft) - Len(CStr(dayNo))), arrD, 0) 'extract the month number
convert_date = DateSerial(y, monthNo, dayNo) 'convert to Date
End Function
Private Function onlyNo(strX As String) As Long
With CreateObject("vbscript.regexp")
.Pattern = "[^0-9]" 'replace everything except numbers
.Global = True
onlyNo = CLng(.replace(strX, "")) 'remove all letters
End With
End Function
The function should be called exactly as in your existing code.
You can simple test it using the next testing Sub. Please, uncomment the commented lines one by one and run it:
Sub testConvert_Date()
Dim d As String
d = "MAI31/2022"
'd = "JUIN20/2022"
'd = "NOV4/2022"
Debug.Print convert_date(d)
End Sub
If you need to adapt the function to work, at request, for English days name, too, I can easily adapt the function creating another parameter to select between languages.
Please, send some feedback after testing it.
Option Explicit
Function convert_date(s As String) As Date
Dim ar, arLang(1), regex, v
Dim y As Integer, m As String, d As Integer
arLang(0) = Split("JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC", ",")
arLang(1) = Split("JANV,FEVR,MARS,AVRIL,MAI,JUIN,JUIL,AOUT,SEPT,OCT,NOV,DEC", ",")
Set regex = CreateObject("vbscript.regexp")
With regex
.Global = False
.MultiLine = False
.Ignorecase = True
.Pattern = "([A-Z]+)(\d{1,2})\/(\d{4})"
End With
If regex.test(s) Then
With regex.Execute(s)(0)
m = .submatches(0)
d = .submatches(1)
y = .submatches(2)
End With
For Each ar In arLang
v = Application.Match(m, ar, 0)
If Not IsError(v) Then
convert_date = DateSerial(y, CInt(v), d)
Exit Function
End If
Next
End If
MsgBox s & " not correct format", vbExclamation
End Function
I am trying to build a loop which prints a list with the 15th day and the last day of each month. The starting date of the list will depend on the current day (num_day), whereas the length of such list will depend on a given N number.
For example, if today is 30/07/2021 (dd/mm/yyyy format), and the N = 5 the list should be the following:
31/07/2021, 15/08/2021, 31/08/2021, 15/09/2021, 30/09/2021
My current VBA code is the following:
Sub print_dates()
N = 9
For i = 0 To N - 1
curr_day = DateAdd("m", i, Date)
num_day = Format(Date, "dd")
If num_day <= 15 Then
If i Mod 2 = 0 Then
print_day = "15/" & Format(curr_day, "mm") & "/" & Format(curr_day, "yyyy")
Else
print_day = DateSerial(Year(curr_day), Month(curr_day), 0)
End If
Else
If i Mod 2 = 0 Then
print_day = DateSerial(Year(curr_day), Month(curr_day), 0)
Else
print_day = "15/" & Format(curr_day, "mm") & "/" & Format(curr_day, "yyyy")
End If
End If
Debug.Print print_day
Next i
End Sub
With my current code the result of the list is:
30/06/2021
15/08/2021
31/08/2021
15/10/2021
31/10/2021
15/12/2021
31/12/2021
15/02/2022
28/02/2022
The months with odd numbers (7, 9, 11, etc.) are being skipped by the code. Also, the list starts with last month's last day.
Are there any suggestions on how to reach the desired result?
Thanks a lot in advance.
One more:
Sub print_dates()
Dim dt As Date, i As Long
dt = Date
For i = 1 To 10
dt = NextDate(dt)
Debug.Print dt
Next i
End Sub
'next date either 15th or last day of month
Function NextDate(ByVal dt As Date)
Dim d As Long, ld As Long, m As Long, y As Long
d = Day(dt)
m = Month(dt)
y = Year(dt)
ld = Day(Application.EoMonth(dt, 0)) 'last day of the month
NextDate = IIf(d < 15, DateSerial(y, m, 15), _
IIf(d < ld, DateSerial(y, m, ld), DateAdd("d", 15, dt)))
End Function
The function below will return the list you want in an array of real dates.
Function DateList(ByVal Dstart As Date, _
ByVal Months As Integer) As Date()
' 300
Dim Fun() As Date ' list of dates
Dim i As Long ' index of Fun()
Dim NextDate As Date
Dim n As Integer ' loop counter: Months
ReDim Fun(1 To Months * 2)
If Day(Dstart) < 15 Then
i = 1
Fun(i) = DateSerial(Year(Dstart), Month(Dstart), 15)
End If
NextDate = DateSerial(Year(Dstart), Month(Dstart) + 1, 1)
For n = 1 To Months
i = i + 1
Fun(i) = NextDate - 1
If i < UBound(Fun) Then
i = i + 1
Fun(i) = DateAdd("d", 14, NextDate)
NextDate = DateAdd("m", 1, NextDate)
End If
Next n
DateList = Fun
End Function
The function takes two arguments. The first date and the number of years. The first date need not be an ultimo or 15th because the function will determine the next available. Therefore you might call the function from your program as shown below.
Private Sub Test_PrintDates()
' 300
Dim MyList() As Date
Dim f As Long
MyList = DateList(Date + 2, 3)
For f = LBound(MyList) To UBound(MyList)
Debug.Print Format(MyList(f), "ddd, mmmm dd, yyyy")
Next f
End Sub
As you see, I used Date + 2 as the first date (Dstart) to test various start dates. The resulting list can be printed in any valid date format as demonstrated above.
Would something like this work better?
Sub print_dates()
Dim N As Long, num_day As Long
Dim curr_day As String, print_day As String
N = 5
For i = 1 To N / 2 + 0.5 Step 0.5 '<- Half step with compensation to N
curr_day = DateAdd("m", i, Date)
num_day = Format(Date, "dd")
If num_day <= 15 Then
If Int(i) / i = 1 Then '<- check for whole numbers instead
print_day = "15/" & Format(curr_day, "mm") & "/" & Format(curr_day, "yyyy")
Else
curr_day = DateAdd("m", i + 1, Date) '<- random fix
print_day = DateSerial(Year(curr_day), Month(curr_day), 0)
End If
Else
If Int(i) / i = 1 Then '<- same change here
print_day = DateSerial(Year(curr_day), Month(curr_day), 0)
Else
print_day = "15/" & Format(curr_day, "mm") & "/" & Format(curr_day, "yyyy")
End If
End If
Debug.Print print_day
Next i
End Sub
Following is an array function.
Option Explicit
Function HalfMonthDateSeries(myDate As Date, count As Long)
'Array (Contrl+Shift+Enter CSE) function
'returns one dimensional array of dateserial 15th and EOM from myDate
'While entering in a column wrap this function in transpose function
Dim arr(), i As Long
ReDim arr(count - 1) 'being 0 based one dimensional array
For i = LBound(arr) To UBound(arr)
If i = LBound(arr) Then
arr(i) = IIf(Day(myDate) <= 15, DateSerial(Year(myDate), _
Month(myDate), 15), WorksheetFunction.EoMonth(myDate, 0))
Else
arr(i) = IIf(Day(arr(i - 1)) = 15, _
WorksheetFunction.EoMonth(arr(i - 1) + 1, 0), arr(i - 1) + 15)
End If
Next i
HalfMonthDateSeries = arr
End Function
In procedure
Sub Print_HalfMonthDateSeries()
Dim arr, i As Long
arr = HalfMonthDateSeries(Date, 5)
' or arr = HalfMonthDateSeries(#7/13/2021#, 5)
For i = LBound(arr) To UBound(arr)
Debug.Print CDate(arr(i))
' or Cells(i + 2, 1) = CDate(arr(i))
Next i
End Sub
Since I asked a wrong question in the last post, but still improved a lot (I already created a Planning table in Excel, if someone want it I will be happy to share), here is what im trying do to: Cell B2: Start Date and Cell B3: End Date
Example:
B2 --> 11/03/2019
B3 --> 22/04/2019
Here is my code so far with the help of this community
Option Explicit
Sub Sample()
Dim sDate As Date, eDate As Date
Dim NoOfWeeks As Long
Dim arr As Variant
Dim i As Long
Dim myCellToStart As Range
Set myCellToStart = Worksheets(1).Range("D4")
Dim myVar As Variant
Dim myCell As Range
Set myCell = myCellToStart
With Worksheets("Foglio1")
sDate = .Range("B2")
If Weekday(sDate, vbMonday) <> 1 Then
sDate = DateAdd("d", 7 - Weekday(sDate, vbMonday) + 1, sDate)
NoOfWeeks = 1
End If
eDate = .Range("B3")
End With
If sDate = eDate Then
NoOfWeeks = NoOfWeeks + 1
Else
NoOfWeeks = NoOfWeeks + WorksheetFunction.RoundUp((eDate - sDate) / 7, 0)
End If
ReDim arr(1 To NoOfWeeks)
For i = 1 To NoOfWeeks
arr(i) = i
Next i
End Sub
Basically with my current code I would obtain an array with this ouput: arr(1, 2, 3, 4, 5, 6)
Related to this --> See Calendar
I would like to obtain: arr(11, 12, 13, 14, 15, 16, 17)
Using Application.WeekNum will be much more simple:
Option Explicit
Sub Test()
Dim StartDate As Date, EndDate As Date
With ThisWorkbook.Sheets("Foglio1") 'remember to fully qualify your ranges, including the workbook
StartDate = .Range("B2")
EndDate = .Range("B3")
End With
Dim StartWeek As Long, EndWeek As Long
StartWeek = Application.WeekNum(StartDate, 2)
EndWeek = Application.WeekNum(EndDate, 2)
Dim arr
Dim i As Long
ReDim arr(StartWeek To EndWeek)
For i = StartWeek To EndWeek
arr(i) = i
Next
End Sub
This is an alternative way:
Sub Test()
Dim StrtD As Long, EndD As Long
Dim arr As Variant
With Sheets("Foglio1")
StrtD = Application.WeekNum(.Cells(1, 2).Value, 2)
EndD = Application.WeekNum(.Cells(2, 2).Value, 2)
arr = Application.Transpose(.Evaluate("ROW(" & StrtD & ":" & EndD & ")"))
End With
End Sub
The Application.Transpose() creates an 1-D array you can call through arr(x) where x is any position within the array. You can leave the transpose if you want to create a 2-D array.
To not use .Transpose but use .Columns to return a 1-D array you can tweak the code to:
Sub Test()
Dim StrtD As Long, EndD As Long
Dim arr As Variant
With Sheets("Foglio1")
StrtD = Application.WeekNum(.Cells(1, 2).Value, 2)
EndD = Application.WeekNum(.Cells(2, 2).Value, 2)
arr = .Evaluate("COLUMN(" & .Cells(1, StrtD ).Address & ":" & .Cells(1, EndD ).Address & ")")
End With
End Sub
I guess it's a matter of preference as both ways will return an array > arr(11, 12, 13, 14, 15, 16, 17)
Here is what im trying to do: Cell B2: Start Date and Cell B3: End Date
Example:
B2 --> 01/01/2019
B3 --> 01/03/2019
I would like to get all the week numbers and put them in an array
Here is a picture of the Excel cells
Here is my code so far
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim StartD As Date, EndD As Date
Set wks = ThisWorkbook.Sheets("Foglio1")
Worksheets("Foglio1").Range("D2:XZ39").Clear
StartD = Worksheets("Foglio1").Cells(2, 2)
EndD = Worksheets("Foglio1").Cells(3, 2)
I would like to loop though the given two dates: 01/01/2019 , 01/03/2019 get the week numbers and put them in an array(if it's possible)
So my output would be:
Array(1, 2, 3, 4, 5, 6, 7, 8, 9) --> Since between January and March there are 9 weeks
If you do not want Calendar Weeks and want to include a week even if there is one day from it then you can try this.
Logic
It finds when the next week is starting. So default number of weeks is 1.
Loops and counts the number of days (Say Monday and then Tuesday and so on) between two dates and whichever is highest, it returns it and adds it to 1.
Also there is no need to loop and create an array. You can create a sequential array in One Go
Code
Option Explicit
Sub Sample()
Dim WeeksCount As Long
Dim CurCount As Long
Dim countOfWeeks As Long
Dim i As Long, tmpCount As Long
Dim sDate As Date, eDate As Date
sDate = DateSerial(2019, 1, 6)
eDate = DateSerial(2019, 1, 8)
If Weekday(sDate, vbMonday) <> 1 Then
sDate = DateAdd("d", 7 - Weekday(sDate, vbMonday) + 1, sDate)
WeeksCount = 1
End If
For i = 1 To 7
CurCount = GetMeMyKindOfWeeksTotal(sDate, eDate, i)
If tmpCount < CurCount Then tmpCount = CurCount
Next i
WeeksCount = WeeksCount + tmpCount
Dim MyArray
MyArray = Evaluate("Row(1" & ":" & WeeksCount & ")")
If WeeksCount = 1 Then
Debug.Print MyArray(1)
Else
For i = LBound(MyArray) To UBound(MyArray)
Debug.Print MyArray(i, 1)
Next i
End If
End Sub
Private Function GetMeMyKindOfWeeksTotal(ByVal sDate As Date, ByVal eDate As Date, dy As Long)
Dim j As Long
Dim TotalDays As Long
For j = sDate To eDate
If Weekday(j) = dy Then
TotalDays = TotalDays + 1
End If
Next
GetMeMyKindOfWeeksTotal = TotalDays
End Function
Various Tests
sDate = DateSerial(2019, 1, 6)
eDate = DateSerial(2019, 1, 8)
This will give you 2
sDate = DateSerial(2019, 1, 1)
eDate = DateSerial(2019, 3, 1)
This will give you 9
sDate = DateSerial(2019, 1, 1)
eDate = DateSerial(2019, 1, 1)
This will give you 1
sDate = DateSerial(2019, 1, 1)
eDate = DateSerial(2019, 1, 8)
This will give you 2
You could use something like the following
Option Explicit
Sub Sample()
Dim sDate As Date, eDate As Date
Dim NoOfWeeks As Long
Dim arr As Variant
Dim i As Long
With Worksheets("Foglio1")
sDate = .Range("B2")
If Weekday(sDate, vbMonday) <> 1 Then
sDate = DateAdd("d", 7 - Weekday(sDate, vbMonday) + 1, sDate)
NoOfWeeks = 1
End If
eDate = .Range("B3")
End With
If sDate = eDate Then
NoOfWeeks = NoOfWeeks + 1
Else
NoOfWeeks = NoOfWeeks + WorksheetFunction.RoundUp((eDate - sDate) / 7, 0)
End If
ReDim arr(1 To NoOfWeeks)
For i = 1 To NoOfWeeks
arr(i) = i
Next i
MsgBox Join(arr, ";")
End Sub
You can define a UDF like below:
Public Function GetWeekNums(startDate As Date, endDate As Date, Optional varDelim As Variant)
Dim lngStartWeek As Long
Dim lngEndWeek As Long
Dim i As Long
If IsMissing(varDelim) Then varDelim = ","
lngStartWeek = Application.WorksheetFunction.WeekNum(startDate)
lngEndWeek = Application.WorksheetFunction.WeekNum(endDate)
For i = lngStartWeek To lngEndWeek
GetWeekNums = GetWeekNums & " " & i
Next
GetWeekNums = Replace(Trim(GetWeekNums), " ", varDelim & " ")
End Function
and then use it in workbook like:
=GetWeekNums(B2,B3,";")
If someone prefers just a worksheet formula, you can use:
=ROW(INDEX($A:$A,WEEKNUM($B$2),1):INDEX($A:$A,WEEKNUM($B$3),1))
Depending on when your week starts, use the appropriate return_type argument for the function.
Excelfile
Hello I have an excel files with time stamps in a row as shown in the image
I want to calculate the difference and enter the value in a new column. I tried the following code but it shows a type mismatch error and I don't know why.
I know its easy, but I'm new to VBA so please help me.
\\Sub macro1()
Dim i As Integer
Dim j As Integer
Dim k As Integer
i = 1
j = 2
k = 2
Do While Cells(i, 1).Value <> ""
Cells(k, 2).Value = Cells(j, 1).Value - Cells(i, 1).Value
i = i + 1
j = i + 1
k = i
Loop
End Sub
Your format (2.10.2017 08:08:30) should be manipulated before using CDate to convert the cell value into a date, then use the VBA function DateDiff. See below. Put =timeDiff(A2,A1) in B2, then copy to B3 and down. Below is the VBA code.
Public Function transformCellStrInDate(ByVal rng As Range) As Date
Dim splitArr As Variant, dateArr As Variant, dateStr As String
splitArr = Split(Trim(rng.Value))
dateArr = Split(splitArr(0), ".")
dateStr = dateArr(0) & "/" & dateArr(1) & "/" & dateArr(2) & " " & splitArr(1)
transformCellStrInDate = CDate(dateStr)
Erase dateArr: Erase splitArr
End Function
Public Function timeDiff(ByVal rngY As Range, ByVal rngX As Range) As Long
timeDiff = DateDiff("n", transformCellStrInDate(rngX), transformCellStrInDate(rngY)) / 60 ' in Hours
End Function