I am trying to write a script that searches a list of dates, and identifyies how long date gaps are. I'm new to VBA, and this may be completely wrong, but after referencing several sites, here is what I came up with:
Sub IdentifyGaps()
Dim startdate As Date 'first date in column
Dim enddate As Date 'last date in column
Dim ust As Date 'first date of unemployment
Dim i As Long
ust = ActiveCell.Offset(1, 0).Value
With Sheet6
startdate = [A1]
enddate = .Cells(.Rows.Count, "A").End(xlUp).Value
For i = startdate To enddate
If ust <> DateAdd("d", 1, i) Then
Sheet6.[C1].Value = DateDiff("d", i, ust)
End If
Next i
End With
End Sub
I'm not receiving an error, but the macro is not working properly. Right now, it's returning -43074 when it should be returning 15. Any help would be much appreciated!
Here is a screenshot of the data, with the lone date gap it should pick up.
Sub IdentifyGaps()
Dim ws As Worksheet
Dim Date1 As Long, Date2 As Long, Gap As Long, lRow As Long
Set ws = Sheet6
lRow = ws.Range("C" & Rows.Count).End(xlUp).Row
For x = 1 To ws.Range("A" & Rows.Count).End(xlUp).Row
Date1 = ws.Cells(x, 1).Value
Date2 = ws.Cells(x + 1, 1).Value
Gap = DateDiff("d", Date1, Date2)
If Gap > 1 Then
ws.Range("C" & lRow).Value = Gap
lRow = lRow + 1
End If
Next x
Looking at my calendar, I believe your expected result should actually be 17, not 15. This code will return the gap value as a Long value with which you can do whatever you want.
'Reads a column of dates and returns the length of the first gap found
Function IdentifyGaps() As Long
Dim StartDate As Date
Dim EndDate As Date
'This Variable is not needed for this solution, it is instead replaced by Gap
'Dim ust As Date
Dim Gap As Long
'Read cell values into an array for more efficient operation
Dim ReadArray() As Variant
ReadArray = Sheet6.Range("A1").CurrentRegion
Dim LastRow As Long
LastRow = UBound(ReadArray, 1)
StartDate = ReadArray(1, 1)
EndDate = ReadArray(LastRow, 1)
'ThisDate and PreviousDate are declared explicitly to highlight program flow
Dim Row As Long
Dim ThisDate As Date
Dim PreviousDate As Date
For Row = 2 To UBound(ReadArray, 1)
ThisDate = ReadArray(Row, 1)
PreviousDate = ReadArray(Row - 1, 1)
Gap = ThisDate - PreviousDate
If Gap > 1 Then Exit For
Gap = 0
Next Row
IdentifyGaps = Gap
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ProveIt()
Debug.Print IdentifyGaps
End Sub
Related
I have a sheet i am working on that i need to populate all the days between 2 dates for a month 54 times.
I have got together a loop that can do this for the first section - I now need ti replicated 54 times.
I have figured out a loop to copy and paste this range the 54 times which works as it should. however I am wondering whether there is a way to put the date generation loop inside the duplication loop and generate every date rather than copy and paste?
I am mainly looking for the most efficient method as this will potentially be scaled up in future so any pointers with my code would be greatly appreciated.
Sub WriteDatesLoopTest()
'Disables Screen Flickering on Copy/Paste
Application.ScreenUpdating = False
OffsetValue = 42
'----------------------------------------------
Dim StartDate As Range
Dim EndDate As Range
Dim OutputRange As Range
Dim ClearRange As Range
Dim StartValue As Variant
Dim EndValue As Variant
Dim DateRangeCopy As Range
Dim EmployeeCount As Range
Dim MonthValue As Range
'----------------------------------------------
Set ClearRange = Range("A9:A39")
Set StartDate = Range("T4")
Set EndDate = Range("T5")
Set OutputRange = Range("A9")
Set DateRangeCopy = Range("A9:A39")
Set EmployeeCount = Range("O1")
Set MonthValue = Range("J1")
StartValue = StartDate
EndValue = EndDate
'----------Date Generation Loop----------------
If EndValue - StartValue <= 0 Then
Exit Sub
End If
ColIndex = 0
For i = StartValue To EndValue
OutputRange.Offset(ColIndex, 0) = i
ColIndex = ColIndex + 1
Next
'----------Copy & Paste------------------------
n = EmployeeCount
For j = 0 To (n - 1)
'ClearRange.Offset(OffsetValue * j, 0).ClearContents
DateRangeCopy.Copy
With DateRangeCopy.Offset(OffsetValue * j, 0)
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
SkipBlanks = False
End With
'Show Status Bar in Bottom Left
Application.StatusBar = "Progress: " & Format(j / n, "0%")
Next
'Display Message on completion
MsgBox "Dates Generated"
'Removes 'Walking Ants' From copied selection
Application.CutCopyMode = False
'Enables Screen Flickering on Copy/Paste
Application.ScreenUpdating = True
'Reset Status Bar in Bottom Left
Application.StatusBar = False
'-----------------------------------
End Sub
Thank you
Just seen the comments. Yes Code Review would be good. You probably want to move the entire process into an array.
This demonstrates all the required elements.
Option Explicit
Public Sub GenerateDates()
Const LOOPCOUNT As Long = 54
Dim i As Long, j As Long
Dim startDate As Long, endDate As Long, rowCounter As Long
startDate = CLng(Now)
endDate = startDate + 7
Application.ScreenUpdating = False
With ActiveSheet
For i = 1 To LOOPCOUNT
For j = startDate To endDate
rowCounter = rowCounter + 1
.Cells(rowCounter, 1) = j
Next j
rowCounter = rowCounter + 5 '<== Add gap
Next i
.Columns("A").NumberFormat = "m/d/yyyy"
End With
Application.ScreenUpdating = True
End Sub
Doing the same thing in memory (I have included a second dimension as you may have additional columns in your data. My principle was really about showing the dates increment with row gap.)
Option Explicit
Public Sub GenerateDates() '697
Const LOOPCOUNT As Long = 54
Dim i As Long, j As Long
Dim startDate As Long, endDate As Long, rowCounter As Long
startDate = CLng(Now)
endDate = startDate + 7
Dim ROWGAP As Long: ROWGAP = 41-(Enddate-StartDate)
Dim outputArr()
ReDim outputArr(1 To (((endDate - startDate + 1) + ROWGAP) * LOOPCOUNT) - ROWGAP, 1 To 1)
Application.ScreenUpdating = False
With ActiveSheet
For i = 1 To LOOPCOUNT
For j = startDate To endDate
rowCounter = rowCounter + 1
outputArr(rowCounter, 1) = j
Next j
rowCounter = rowCounter + ROWGAP '<== Add gap
Next i
.Cells(1, 1).Resize(UBound(outputArr), UBound(outputArr, 2)) = outputArr 'This is only with one dimensional
.Columns("A").NumberFormat = "m/d/yyyy"
End With
Application.ScreenUpdating = True
End Sub
tl;dr;
The principle is basically that you want an outer loop that increments from 1 to 54. Then an inner loop that increments from start date to end date. I treat date as a Long and simply add one to the startDate until I reach the endDate in the inner loop. For i = 1 To LOOPCOUNT is doing the repeat work... here you could be using your copy paste. I increment the rowCounter variable by 5 before the next repeat to leave some blank rows between repeats.
The first version writes to the sheet for every row with .Cells(rowCounter, 1) = j . That is an expensive operation "touching" the sheet each time. The second version does the same process but doesn't write to the sheet until the very end. Instead, it writes to an array. This is much faster as is all done in memory (no going to disk).
I know how many rows I will have in the array because I know how many times I am repeating the entire process (54), the number of days from startDate and endDate (8) and the number of padding rows I am adding (5). So I can size my array to write to with ReDim outputArr(1 To (((endDate - startDate + 1) + ROWGAP) * LOOPCOUNT) - ROWGAP, 1 To 1). I don't need 5 rows padding on the 54th loop so I remove these from the total row count.
For understanding working with arrays and data in the worksheet the article VBA Arrays And Worksheet Ranges is worth a read, a long with the more general VBA Arrays
The fewer tasks that a subroutine performs, the easier it is to write, test, and modify. For this reason I created a function to generate the output Array.
OffsetValue has a somewhat ambiguous name. I used SectionLength instead.
Sub AddDates()
Const OffsetValue = 42
Dim data() As Variant
data = getDatesArray(#6/1/2018#, #6/30/2018#)
With Worksheets("Sheet1")
.Columns(1).ClearContents
.Range("A1").Resize(UBound(data)).Value = data
End With
End Sub
Function getDatesArray(StartDate As Date, EndDate As Date, Optional SectionLength As Long = 42, Optional RepeatCount As Long = 54) As Variant()
Dim results() As Variant
Dim count As Long, n As Long
ReDim results(1 To SectionLength * RepeatCount, 1 To 1)
If EndDate >= StartDate Then
Do
count = count + 1
For n = 0 To UBound(results) - SectionLength Step SectionLength
results(n + count, 1) = StartDate
Next
StartDate = StartDate + 1
Loop Until StartDate = EndDate
End If
getDatesArray = results
End Function
I know this question seem complicated but what I want to do is simple, I got 2 columns:
I is my Starting Date
L is my ending date
G is where all the dates are supposed to be
What I want to do is get the number of days per period (EndDate - StartDate + 1), add this many rows and change value of G to be written day per day.
I already coded the part below, but it doesn't seem to be right:
Sub Dates()
Dim LastRow As Long
Dim addrows
Dim FindDates
Dim CountDays
Dim dddays
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim i As Long
Dim ir As Long
Set ws = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
With Sheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row - 1
End With
addrows = 2
For ir = 1 To LastRow
FindDates = ws.Range("I" & addrows).Value
CountDays = ws.Range("L" & addrows).Value - ws.Range("I" & addrows).Value + 1
Adddays = 0
For i = 1 To CountDays
ws2.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ws2.Range("A2").Value = Sheets("Sheet1").Range("A" & addrows).Value
ws2.Range("C2").Value = FindDates + Adddays
ws2.Range("C2").Value = ws.Range("G" & addrows).Value
Adddays = Adddays + 1
Next i
addrows = addrows + 1
Next ir
End Sub
File looks as follows:
Can you help me a bit? "ws2.Range("C2").Value = FindDates + Adddays" is giving me an error 13
I is my Starting Date
L is my ending date
G is where all the dates are supposed to be
What I want to do is get the number of days per period (EndDate - StartDate + 1), add this many rows and change value of G to be written day per day.
for what above this should help you:
Sub Dates()
Dim ir As Long, countDays As Long
With Sheets("Sheet1")
For ir = .Cells(.Rows.Count, "I").End(xlUp).row To 2 Step -1
With .Rows(ir)
countDays = .range("L1") - .range("I1") + 1
If countDays > 1 Then
.Offset(1).Resize(countDays - 1).Insert xlDown
.Offset(1).Resize(countDays - 1).value = .value
With .Resize(countDays).Columns("G")
.FormulaR1C1 = "=RC9+ROW()-" & .Rows(1).row
.value = .value
End With
End If
End With
Next
End With
End Sub
The function is supposed to loop over a filtered range appending a certain date to the first "i" lines then moving to the next date and repeating.
It is appending everything to the header instead of moving down a row each time.
It is not erroring, just not acting as expected. Where am I going wrong on this?
Sub Function()
Dim wsExport As Worksheet
Set wsExport = Workbooks("Export Workbook").Worksheets("Export")
Dim uiStartDate As Variant 'I'm using the prefix ui to be User Input
Dim uiEndDate As Variant
Dim uiCount As Variant
Dim cStartDate As Long 'Converted to date
Dim cEndDate As Long
Dim cCount As Long
Dim iDate As Long 'Counter for the date
Dim i As Long 'Counter for the number of items per day.
Dim j As Long 'Counter for Rows
Dim lRow As Long
lRow = Cells.Find(What:="*", LookAt:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False).Row
'Prompt the user for the start date and end date
'uiStartDate = InputBox("Input the first day of week in the format of 01/20/2018", "Start Date User Input")
'uiEndDate = InputBox("Input the last day of week in the format of 01/25/2018", "End Date User Input")
'uiCount = InputBox("Input the number of items per day.", "Installtion Quantity User Input")
uiStartDate = "1/20/2018" 'This is to speed during testing. Will use the above for actual code
uiEndDate = "1/25/2018"
uiCount = "2"
'Convert to their proper data types. (User inputs have to be variants to begin with)
cStartDate = CDate(uiStartDate)
cEndDate = CDate(uiEndDate)
cCount = CLng(uiCount)
With wsExport.Range("A:AP")
.AutoFilter Field:=19, Criteria1:=">=" & uiStartDate
End With
iDate = cStartDate
j = 2
i = 1
Do While j <= lRow
DoEvents
If Not wsExport.Rows(j).Hidden Then
wsExport.Range("S" & j).Value = wsExport.Range("S" & j).Value & "-" & iDate
i = i + 1
End If
If i > cCount Then
i = 1
iDate = iDate + 1
End If
If iDate > cEndDate Then
j = lRow + 1
End If
j = j + 1
Loop
End Sub
Here's a simplified example using a different approach to looping over the table:
EDIT: updated to your actual process of incrementing the date every two rows...
Sub Tester()
Dim sht As Worksheet, rngTable As Range, rw As Range, r As Long
Dim sDate, eDate, dt, i As Long
Set sht = ActiveSheet
Set rngTable = sht.Range("A1").CurrentRegion
rngTable.AutoFilter 'clear any previous filter
rngTable.AutoFilter field:=4, Criteria1:=">3" 'filter to required rows only
'some dates...
sDate = Date
eDate = Date + 3
dt = sDate 'set date to add
i = 0
For r = 2 To rngTable.Rows.Count
Set rw = rngTable.Rows(r)
'is the row visible?
If Not rw.Hidden Then
With rw.Cells(2)
.Value = .Value & " - " & Format(dt, "dd/mm/yyyy")
End With
i = i + 1
If i Mod 2 = 0 Then dt = dt + 1 '<< next date every 2 visible rows
If dt > eDate Then Exit For '<< exit if run out of dates
End If
Next r
End Sub
xlCellTypeVisible does not do what you want when working with an offset from a cell like this. Just use an IF instead:
For i = 1 To cCount
currentRow = currentCell.Offset(1, 0).Row
Set currentCell = wsExport.Range("S" & currentRow)
if currentcell.rowheight > 0 then currentCell.Value = currentCell.Value & "- " & iDate
Next i
Column B is my data - if there is a date value in column B please return week ending date in column C. Need a VBA code to accomplish this
Column B Column C
11/9/2016 11/11/2016
11/8/2016 11/11/2016
4/4/2017 4/7/2017
(blank) (blank)
3/28/2017 3/31/2017
Below is all I could get, but it's not any good.
Dim FirstDayInWeek, LastDayInWeek As Variant
Dim dtmDate As Date
dtmDate = Range("B2:B")
LastDayInWeek = dtmDate - Weekday(dtmDate, vbUseSystem) + 7
MsgBox LastDayInWeek
I replied to your comment on how to find the start date of week from a given date?, but here it is as an answer:
Function ReturnDate(DateRange As Date, Optional DayInWeek = 1) As Date
ReturnDate = DateRange - Weekday(DateRange, vbUseSystem) + DayInWeek
End Function
=ReturnDate(A1) gives Monday
=ReturnDate(A1,2) gives Tuesday
.
=ReturnDate(A1,5) gives Friday < --- This is the one you're after.
=ReturnDate(A1,7) gives Sunday.
A blank cell will give 01/01/1900, but you could add a check for that or format the cell not to show 0.
Perhapse you could take an approach like the one below
Sub ReturnWeekEndDate()
Dim InpRng As Range
Dim i As Long
Set InpRng = ActiveSheet.Range("A2:B5")
For i = 1 To InpRng.Rows.Count
If IsDate(InpRng.Cells(i, 1).Value) And IsDate(InpRng.Cells(i, 2).Value) Then
InpRng.Cells(i, 1).Offset(0, 2) = InpRng.Cells(i, 1).Value - Weekday(InpRng.Cells(i, 1).Value, vbUseSystem) + 7
End If
Next i
End Sub
Give this a try:
Sub INeedADate()
Dim i As Long, N As Long, r As Range, Bigr As Range
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To N
Set r = Cells(i, "B")
If IsDate(r.Value) Then
addy = r.Address
r.Offset(0, 1).Value = Evaluate(addy & "-WEEKDAY(" & addy & ",3)+IF(WEEKDAY(" & addy & ",3)>4,11,4)")
End If
Next i
End Sub
This is similar to using the worksheet formula:
=B1-WEEKDAY(B1,3)+IF(WEEKDAY(B1,3)>4,11,4)
Or try this...
Sub GetFridayDate()
Dim LastDayInWeek As Date
Dim Rng As Range, Cell As Range
Dim lr As Long
lr = Cells(Rows.Count, 2).End(xlUp).Row
Set Rng = Range("B2:B" & lr)
For Each Cell In Rng
If IsDate(Cell.Value) Then
LastDayInWeek = Cell + 8 - Weekday(Cell, vbFriday)
Cell.Offset(0, 1) = LastDayInWeek
End If
Next Cell
End Sub
You said that this would be part of a process...so, just call the function as I have shown, and you're golden! BOOM!
Sub FindEndOfWeek_Test()
Call FindEndOfWeek(ActiveSheet, 1, 2, 6, 1)
End Sub
Function FindEndOfWeek(Sht As Worksheet, KnownDate_Column As Integer, _
EndOfWeek_Column, EndOfWeek As Integer, _
StartingRow As Long)
' This function takes in a spreadsheet, and and determines the date at the end
' of the week, based on known parameters being passed into the function.
'
Dim a As Long
Dim LastRow As Long
Dim EvalDate As Date
Dim NewDate As Date
' Determine the last row of the column you are working with
LastRow = Sht.Cells(Sht.Rows.Count, KnownDate_Column).End(xlUp).Row
' Loop through your entire spreadsheet to determine the end of the week for all rows
For a = StartingRow To LastRow
If IsDate(Sht.Cells(a, KnownDate_Column).Value) = True Then
NewDate = Sht.Cells(a, KnownDate_Column).Value
EvalDay = Weekday(NewDate)
' Determine the known date day of the week, and add accordingly.
If EvalDay < EndOfWeek Then
Sht.Cells(a, EndOfWeek_Column).Value = NewDate + (EndOfWeek - EvalDay)
ElseIf EvalDay > EndOfWeek Then
Sht.Cells(a, EndOfWeek_Column).Value = NewDate + (7 - EvalDay + EndOfWeek)
Else
Sht.Cells(a, EndOfWeek_Column).Value = NewDate
End If
End If
Next a
End Function
I think no need for vba, you use below formula:
=IF(B2<>"",B2+(7-WEEKDAY(B2,16)),"")
If you really need VBA code for this problem, which I did, you can convert the excel formula into a one-line solution like so:
WeekendingDate = Date + 7 - WorksheetFunction.Weekday(Date + 7 - 6)
I am a newbie in vba and I am trying to get in vba all dates between 2 dates, for example I will call the function with the parameters 01-01-2015 and 15-01-2015, and I will get in return an array with all the dates possibles, i.e :
01-01-2015
02-01-2015
03-01-2015
.....
15-01-2015
I didn't find the answer on the forums, so thanks in advance for your help.
you can simply convert the dated in long and make loop(+1) and get all dated between 2 dates(convert that to date again)
Sub Calling()
Dim test
test = getDates(#1/25/2015#, #2/5/2015#)
End Sub
Function getDates(ByVal StartDate As Date, ByVal EndDate As Date) As Variant
Dim varDates() As Date
Dim lngDateCounter As Long
ReDim varDates(1 To CLng(EndDate) - CLng(StartDate))
For lngDateCounter = LBound(varDates) To UBound(varDates)
varDates(lngDateCounter) = CDate(StartDate)
StartDate = CDate(CDbl(StartDate) + 1)
Next lngDateCounter
getDates = varDates
ClearMemory:
If IsArray(varDates) Then Erase varDates
lngDateCounter = Empty
End Function
Function to get all dates from given range
Function GetDatesRange(dateStart As Date, dateEnd As Date) As Collection
Dim dates As New Collection
Dim currentDate As Date
currentDate = dateStart
Do While currentDate <= dateEnd
dates.Add currentDate
currentDate = DateAdd("d", 1, currentDate)
Loop
Set GetDatesRange = dates
End Function
Sample usage
Dim dateStartCell as Range, dateEndCell as Range
Dim allDates as Collection
Dim currentDateSter as Variant
Dim currentDate as Date
Set dateStartCell = ActiveSheet.Cells(3, 3)
Set dateEndCell = ActiveSheet.Cells(3, 6)
Set allDates = GetDatesRange(dateStartCell.Value, dateEndCell.Value)
For Each currentDateSter In allDates
currentDate = CDate(currentDateSter)
'Do something with currentDate
Next currentDateSter
An array 'sn' containing all dates from 01-01-2015 to 15-01-2015.
Msgbox introduced to illustrate the result.
Sub M_snb()
sn = Evaluate("index(text(datevalue(""01-01-2015"")+row(1:" & DateDiff("d", CDate("01-01-2015"), CDate("15-01-2015")) & ")-1,""dd-mm-yyyy""),)")
MsgBox sn(1, 1) & vbLf & sn(2, 1) & sn(UBound(sn), 1)
End Sub
Maybe this.
Function udf_Array_of_Dates(dtSTART As Date, dtEND As Date, rDATEs As Range)
Dim dt() As Date, r As Range, d As Long
For Each r In rDATEs
If r.Value >= dtSTART And r.Value <= dtEND Then
d = d + 1
ReDim Preserve dt(1 To d)
dt(d) = r.Value
End If
Next r
udf_Array_of_Dates = dt
End Function
Proof & syntax:
If you just want to print the dates between two date in excel then my Suggestion is to you try below the code.
Sub DateFill()
Dim Start_Date As Date
Dim End_Date As Date
Dim Number_Of_Days As Integer
Start_Date = InputBox(prompt:="Enter the Start Date", Title:="Date Print", Default:="3/1/2013")
End_Date = InputBox(prompt:="Enter the End Date", Title:="Date Print", Default:="3/23/2013")
Range("A1").Value = Start_Date
'Range("B1").Value = End_Date
Range("A1").Select
Number_Of_Days = DateDiff("d", Start_Date, End_Date) ' Return Day
Number_Of_Days = Number_Of_Days + 1
'Range("C1").Formula = "=DATEDIF(A1, B1, ""D"") "
Selection.AutoFill Destination:=Range("A1:A" & Number_Of_Days), Type:=xlFillDefault
Range("A1:A" & Number_Of_Days).Select
End Sub
Here you have avoid the use of Loop that save the execution time.