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)
Related
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
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
I am trying to create a report in Word that drags data from an Excel spreadsheet. Being on a works PC I am limited as to what I can do (cant open word from excel macro's) so my work-around is to copy all the Information I need from one excel worksheet into another so that is properly formatted / arranged as a data source for a word mail merge.
The problem I have is that I want to copy the records that run between 07:00 on one day to 07:00 the next. It went a bit wrong when I added a nested IF for the times.
Any help is much appreciated,
Rgds Iain
Sub CopyFromLog()
Dim LastRow As Long
Dim i As Long, j As Long, ns As Date, nf As Date, o As Date, f As String, s As String, t As Date
With Worksheets("Log")
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
With Worksheets("Data")
Worksheets("Data").Rows("3:" & LastRow).Clear
j = .Cells(.Rows.Count, "B").End(xlUp).Row + 2
End With
With Worksheets("Navigation")
ns = Worksheets("Navigation").Cells(3, "C").Value ' the report start date
nf = Worksheets("Navigation").Cells(4, "C").Value ' the report end date
End With
For i = 2 To LastRow
With Worksheets("Log")
o = Worksheets("Log").Cells(i, "B").Value 'start date
t = Worksheets("Log").Cells(i, "V").Value 'end date
s = Worksheets("Log").Cells(i, "R").Value 'start time
f = Worksheets("Log").Cells(i, "W").Value 'finish time
If o <= ns And s >= "07:00" Then
If t >= nf And f <= "07:00" Or t >= nf And f <= "R" Then
.Rows(i).Copy Destination:=Worksheets("Data").Range("A" & j)
j = j + 1
End If
End If
End With
Next i
End Sub`
Here is a minor rewrite of your procedure. Refer to the comments for individual observations.
Sub CopyFromLog()
Dim LastRow As Long, i As Long, j As Long
Dim ns As Date, nf As Date, o As Date, t As Date
Dim f As String, s As String
With Worksheets("Log")
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
With Worksheets("Data")
' You realize that LastRow was just defined as the last row on the Log workbook
' and you are now using it on the Data worksheet to clear rows
.Rows("3:" & LastRow).Clear
'I don;t understand this next line. You just cleared everthing from row 3 down so j should be 2
j = .Cells(.Rows.Count, "B").End(xlUp).Row + 2
End With
With Worksheets("Navigation")
ns = .Cells(3, "C").Value + TimeSerial(7, 0, 0) ' the report start dateTIME
nf = ns + 1 '24 hours later
End With
With Worksheets("Log")
For i = 2 To LastRow
o = .Cells(i, "B").Value + CDate(.Cells(i, "R").Value) 'start dateTIME
t = .Cells(i, "V").Value + CDate(.Cells(i, "W").Value) 'end dateTIME
'I couldn't figure out your logic so I made my own.
'Yours looked backwards and you were comparing f to the leffter "R" (f was never assigned a value either)
If o >= ns And t < nf Then
.Rows(i).Copy Destination:=Worksheets("Data").Range("A" & j)
j = j + 1
End If
Next i
End With
End Sub
The big difference is that I have discarded the notion of attempting to get a correct answer by comparing strings that look like times and resorted to bringing the times back into the dates so that the ns var would be something like 07/30/2016 07:00 I adopted a similar approach for all other datetimes in order that direct comparison could be made.
i need to change the value of all the cells in my range for "portfolio + the following working day data". So for instance, today I would need to have the values of my range as "portfolio05042015". I have already set my range as you can see
Sub SelectNonBlanks()
Dim rng As Range
Set rng = Range("A1:A10000")
rng.SpecialCells(xlCellTypeConstants).Select
End Sub
So now, i just need to change their values. I would really appreciate your help
Thank you
You can assign value to selected range, for example:
Selection.Value = "portfolio" & Format(Now, "ddmmyyyy")
If you want nextworkday you can use this function or find someting using google:
Function NextWorkday()
Select Case Weekday(Now, vbMonday) ' - Monday is first day of work you can change this for example for vbSunday. In this example every Saturday and Sunday are holiday
Case 5
NextWorkday = Now + 3
Case 6
NextWorkday = Now + 2
Case Else
NextWorkday = Now + 1
End Select
Holidays = Array("14042015", "16042015") 'your holidays list, format ddmmyyyy
Index = 0
For Each ArrMember In Holidays
If Format(NextWorkday, "ddmmyyyy") = Holidays(Index) Then
NextWorkday = NextWorkday + 1
End If
Index = Index + 1
Next
NextWorkday = Format(NextWorkday, "ddmmyyyy")
End Function
Your sub with NextWorkday function
Sub SelectNonBlanks()
Dim rng As Range
Set rng = Range("A1:A10000")
rng.SpecialCells(xlCellTypeConstants).Select
Selection.Value = "portfolio" & NextWorkday
End Sub
If your selection is correct:
For Each myCell In Selection
myCell.Value = CStr(myCell.Value) & " " & CStr(Format(Date, "ddmmyyyy"))
Next myCell