I am (still) programming in VB6, but I think this problem is not program language related.
I need to show one Picture out of 7 Pictures (named 1.jpg to 7.jpg) every calendar week, beginning with Calendar week 3, which shows picture nr.1
Example:
(year and calendar week together as 2022/03)
202203=1.jpg
202204=2.jpg
202205=3.jpg
202206=4.jpg
202207=5.jpg
202208=6.jpg
202209=7.jpg
202210=1.jpg
202211=2.jpg
etc.
How can I do this??
Also, Years can have 52 or 53 weeks, but this has to continue like above...
Appreciate any help, thank you in advance.
Here is some code that gives the results you desire. It should be fairly self-explanatory:
Option Explicit
Private Sub Test()
Dim dt As Date
Dim i As Integer
dt = DateSerial(2022, 1, 17) 'start at 3rd calendar week
For i = 1 To 100
Debug.Print Format(dt, "mm/dd/yyyy") & vbTab & Year(dt) & _
Format(ISOWeekNumber(dt), "00") & vbTab & GetPicture(dt)
dt = DateAdd("d", 1, dt)
Next
End Sub
Private Function GetPicture(ByVal dt As Date) As String
Dim dp As Integer
dp = ISOWeekNumber(dt) Mod 7 - 2
If dp <= 0 Then dp = dp + 7
GetPicture = dp & ".jpg"
End Function
Private Function ISOWeekNumber(ByVal dt As Date) As Integer
ISOWeekNumber = DatePart("ww", dt, vbMonday, vbFirstFourDays)
End Function
This produces the following results:
Related
I want to display the weeks dates based on a week number that I get from my db.
So if I get week=43 then it would display all 7 dates for that week.
Like this.
M=23
T=24
W=25
T=26
F=27
S=28
S=29
Have tested with a lot of date formating but I can't get it working.
So any input really appreciated, thanks!
I ended up with this, works perfect!
currentDate = Date
weekNumber=DatePart("ww", currentDate, vbMonday, vbFirstFourDays)
y = Year(Date)
Public Function FirstDayOfWeek(Year, Week)
Dim TempDate
TempDate = DateSerial(Year, 1, 1)
Do Until DatePart("ww", TempDate, vbMonday, vbFirstFourDays) = 1
TempDate = TempDate + 7
Loop
TempDate = TempDate + (7 * (Week - 1))
FirstDayOfWeek = TempDate - Weekday(TempDate, vbMonday) + 1
End Function
Dim startDatum
Dim slutDatum
startDatum = FirstDayOfWeek(y, weekNumber)
slutDatum = startDatum + 6
mon=DatePart("d", startDatum)
tus=DatePart("d", startDatum+1)
wen=DatePart("d", startDatum+2)
tur=DatePart("d", startDatum+3)
fri=DatePart("d", startDatum+4)
sat=DatePart("d", startDatum+5)
sun=DatePart("d", startDatum+6)
Well, there isn't really an inverse DatePart() function, so you have to make your own calculations.
dim w, wd, y, m, i
y = Year(Date) '- year of the week in question; I'm using today's date
w = 43
wd = DateAdd("d",w*7,CDate("1/1/" & y)) '- adjust as needed for 1st week of year
m = DateAdd("d",2-Weekday(wd),wd) '- find Monday of week
Hopefully, you can go from there.
Wondering if someone could help me in developing a simple user interfacing macro.
I have a set of data with the first Column (A) being dates. The date range can be an arbitrary range so could go from any start date to end date (most of the time its a 6/8 weeks). Lets say for arguments sake the date range goes from 31/12/2014 18:00 to 09/02/2015 18:00 (note date is UK format of dd/mm/yyyy). I would like the user to be asked for a start and end date range that they went - say 01/01/2015 to 31/01/2015. Once they have chosen the range the macro should delete everything BEFORE their selected date range (and shift cells up) and delete everything AFTER their selected date range. The date range is in increments of 10 minutes.
I've written some code to start off:
Public Sub DateRngInput()
Dim startDate As String
Dim endDate As String
Dim sRow As Long
Dim eRow As Long
Dim lastRow As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
startDate = Left(Worksheets("Template").Cells(1, 1), 10)
endDate = Left(Worksheets("Template").Cells(lastRow, 1), 10)
sDate = InputBox("Choose Start date (dd/mm/yyyy)" & vbNewLine & vbNewLine & "Data range starts at " & startDate)
eDate = InputBox("Choose End date (dd/mm/yyyy)" & vbNewLine & vbNewLine & "Data range ends at " & endDate)
'On Error Resume Next
sRow = Worksheets("Template").Range("$A$1:$A" & lastRow).Find(sDate, LookAt:=xlPart).Row
eRow = Worksheets("Template").Range("$A$1:$A" & lastRow).Find(eDate, SearchDirection:=xlPrevious, LookAt:=xlPart).Row
MsgBox ("Your date range is from: " & vbNewLine & sDate & " at Row " & sRow & vbNewLine & "To " & vbNewLine & eDate & " at Row " & eRow)
End Sub
The macro errors out at the following line with the Run-Time error '91':
sRow = Worksheets("Template").Range("$A$1:$A" & lastRow).Find(sDate, LookAt:=xlPart).Row
Any help would be much appreciated!
Thanks.
Say we have data like:
Notice the material is not even sorted! We wish to retain only data between 1 February 2015 and 15 February 2015.
We will loop from the bottom moving up. We delete all rows outside the date limits
Sub DateKleaner()
Dim early As Date, late As Date, N As Long
Dim dt As Date
early = DateSerial(2015, 2, 1)
late = DateSerial(2015, 2, 15)
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 1 Step -1
dt = Cells(i, 1).Value
If dt > late Or dt < early Then
Cells(i, 1).EntireRow.Delete
End If
Next i
End Sub
We will be left with:
EDIT#1:
Here is some code which asks the User to supply the dates:
Sub DateKleaner()
Dim early As Date, late As Date, N As Long
Dim dt As Date
early = CDate(Application.InputBox(Prompt:="Please enter start date:", Type:=2))
late = CDate(Application.InputBox(Prompt:="Please enter end date:", Type:=2))
MsgBox early & vbCrLf & late
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 1 Step -1
dt = Cells(i, 1).Value
If dt > late Or dt < early Then
Cells(i, 1).EntireRow.Delete
End If
Next i
End Sub
Naturally you would probably use your own UserForm to accomplish the same thing.
I am writing a macro that processes an excel with lots of data. One of the rows contains a date range like wkstartdate - wkenddate and I would like to use dateadd function to print next date range every week (like '27-01-14 - 02-02-14' in below case) but unable to do so.
'06-01-14 - 12-01-14'
'13-01-14 - 19-01-14'
'20-01-14 - 26-01-14'
I used below excerpt which fails:
Range("E" & Lastrow).Select
prwk = Split(ActiveCell.Value, "-")
'curr_wkstart = DateAdd("d", 7, prwk(1)) 'error as maybe prwk(1) isnt correct format
'curr_wkend = DateAdd("d", 7, prwk(2)) 'error
Range("E" & Lastrow + 1).Value = curr_wkstart & curr_wkend 'no result
For testing purpose I print, prwk(1) which is 20/01/14 in the above case, in a diff cell and add 7 days, which gives me 1/21/2020 instead of '27/01/14'. I also tried using Cdate function, but still error
Can you please advise??
I think what you want to use here are the Format and DateSerial functions. Here's how I came at it:
Function GetNextWeek(TheStartWeek)
a = Split(TheStartWeek, " - ")
b = Split(a(1), "-")
c = DateSerial(b(2), b(1), b(0)) + 1
d = c + 6
GetNextWeek = Format(c, "dd-mm-yy") & " - " & Format(d, "dd-mm-yy")
End Function
Sub Test()
Debug.Print GetNextWeek("13-01-14 - 19-01-14") 'Givs you "20-01-14 - 26-01-14"
End Sub
Hope this helps.
I am tring to add x number of days to a Long date with a pop up box.
Public Function AskForDeadlinePlus4() As String
Dim strUserResponse As String
strUserResponse = InputBox("Enter Validuntil Date: Add # of Days To Survey end date")
strUserResponse = FormatDateTime(strUserResponse + I2, vbLongDate)
ActiveSheet.Cells(2, 10).Value = strUserResponse 'the 2, 10 is the cell reference for J2 - row 2, column 10.
End Function
Where Survey end date in cell I2.
When I run this I get (Googling how to do this I am tiring)
4 + I2 (where I2 = Friday, April 05, 2013) >> Wednesday, January 03, 1900
of course I need Tuesday, April 09, 2013
Thanks
Have you used the DateAdd function?
Sub DateExample()
Dim strUserResponse As String '## capture the user input'
Dim myDate As Date '## the date you want to add to'
Dim numDays As Double '## The number of days you want to add'
strUserResponse = InputBox("Enter Validuntil Date: Add # of Days To Survey end date")
numDays = InputBox("How many days to add?")
myDate = CDate(strUserResponse)
MsgBox DateAdd("d", numDays, myDate)
End Sub
I think this code is what your after using the DateAdd(<base e.g. Day = "D">, <number>, <date>) function:
Public Function AskForDeadlinePlus4() As String
Dim strUserResponse As Date, iNumber As Long, rResponse As Variant
AskForDeadlinePlus4 = "" 'set default value
iNumber = CLng([I2])
rResponse = InputBox("Enter Validuntil Date: Add " & iNumber & " Day(s) To Survey end date")
If rResponse = False Then
'no value entered
Exit Function
ElseIf Not IsDate(rResponse) Then
'no date entered
Exit Function
Else
'valid date entered
strUserResponse = DateAdd("D", iNumber, CDate(rResponse))
End If
AskForDeadlinePlus4 = FormatDateTime(strUserResponse, vbLongDate)
End Function
Just a few points though:
The input function will return the Boolean FALSE if no input is entered.
The test you used above is a function and will return a value when used
If you want to use in in another VBA code, i = AskForDeadlinePlus4 is its usage;
But you can also use it in a cell but only when necessary as with every calculation this will prompt an input and for every cell its in, =AskForDeadlinePlus4; and
Plus I've added a check to see if a date was entered as the user may not enter a valid one.
If you want to use in VBA:
Sub GetInfo()
'the 2, 10 is the cell reference for J2 - row 2, column 10.
ActiveSheet.Cells(2, 10).Value = AskForDeadlinePlus4
End Sub
Instead of using DateAdd, which requires more typing, you could also use DateValue. Following would do it.
DateValue(strUserResponse )+I2
Another solution would be using the conversion function, CDate.
CDate(strUserResponse )+I2
I'm trying to copy and paste a range, to create a 28 by 28 grid of numbers "rotating" the values so that each time the range is pasted into the next column, the range is moves down by one row and the last value "overflows" back to the top of the next row, I've got this far but am stumped on the overflow part (i' relative newbie to VBA)
Sub Test()
Dim oRange As Range
Set oRange = ActiveSheet.Range("A1:A28")
Dim i As Integer
For i = 1 To 28
oRange.Copy
oRange.Offset(i, i).PasteSpecial xlPasteAll
Next i
End Sub
Also I need to copy and paste values and formatting of the cells
Hope you guys can help
Thanks
Dan
Sub Test()
Dim oRange As Range
Dim startColumn As String
Dim rangeStart As Integer
Dim rangeEnd As Integer
Dim cellCount As Integer
Dim i As Integer
startColumn = "A"
rangeStart = 1
rangeEnd = 28
cellCount = rangeEnd - rangeStart + 1
For i = 1 To cellCount - 1
Set oRange = ActiveSheet.Range(startColumn & rangeStart & _
":" & startColumn & (rangeEnd - i))
oRange.Copy
oRange.Offset(i, i).PasteSpecial xlPasteAll
Set oRange = ActiveSheet.Range(startColumn & (rangeEnd - i + 1) & _
":" & startColumn & rangeEnd)
oRange.Copy
oRange.Offset((-1 * cellCount) + i, i).PasteSpecial xlPasteAll
Next i
End Sub
EDIT:
to insert a blanck row at index 'i':
Rows(i & ":" & i).Select
Selection.Insert Shift:=xlDown
to insert 5 rows at the top of the worksheet insert a row 5 times at index 1:
For i = 1 To 5
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Next