I have a macro that filters data by each unique value in column A and then adds lines for any missing dates. The Macro will only add the missing dates for the start of the month to the first group. The rest of the missing dates are added to all groups without any issues.
I think the issue is the 'If I = 2 then prevcell = start_date'. Is there any way to fix this so each time the macro filters it adds the missing dates at the start of the group even when not in line 2?
'Sub Macro1()
Dim aNames As Variant, Itm As Variant
With Range("A1", Range("A" & Rows.Count).End(xlUp))
.AdvancedFilter Action:=xlFilterInPlace, Unique:=False
aNames = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible).Value
For Each Itm In aNames
.AutoFilter Field:=1, Criteria1:=Itm
'Do whatever you want with an individual name here
Call Macro2
Next Itm
.AutoFilter
End With
Sub Macro2()
Dim wks As Worksheet, ssh As Worksheet
Set wks = Worksheets("NAV_REPORT_FSIGLOB1")
Set ssh = Worksheets("SUMMARY")
Dim lastRow As Long, start_date As Date, end_date As Date, curcell As Date
lastRow = wks.Range("D2").End(xlDown).Row
start_date = ssh.Range("A2") - 1
end_date = ssh.Range("B2")
With wks.Cells(lastRow, 4)
If .Value < end_date Then
.EntireRow.Copy
.EntireRow.Insert xlShiftDown
lastRow = lastRow + 1
.Value = end_date
End If
End With
For i = lastRow To 2 Step -1
curcell = wks.Cells(i, 4).Value
If i = lastRow Then curcell = end_date
prevcell = wks.Cells(i - 1, 4).Value
If i = 2 Then prevcell = start_date
Do Until curcell - 1 <= prevcell
wks.Rows(i).Copy
wks.Rows(i).Insert xlShiftDown
curcell = wks.Cells(i + 1, 4) - 1
wks.Cells(i, 4).Value = curcell
Loop
Next i`
The answer below assumes that all your three questions here, here and here is actually the same which have the same expected result.
I have a macro that filters data by each unique value in column A
The code below is not involving a unique value and a filtering.
The start and end date would need updated monthly so needs to be
easily changed e.g. cells A2 and B2 on the "Summary" worksheet.
The code will involve a start date (dtS) value and end date value (dtE).
adds lines for any missing dates
The row addition regarding the dtS will happen only if the first value in column D is bigger then dtS. If the first value in column D is smaller than the dtS then it does nothing
The row addition regarding the dtE will happen only if the last value in column D is smaller then dtE. If the last value in column D is bigger than the dtE then it does nothing.
before running the sub :
In a condition where dtS = "02-Oct-22": dtE = "20-Oct-22", If yellow column D value is 2 Oct 22, then no process is performed. If blue column D value is 23 Oct 22, then no process is performed.
The expected result :
yellow will be 2 rows, where column D value is from 2 to 3 Oct 22.
orange will be 3 rows, where column D value is from 8 to 10 Oct 22.
green will be 5 rows, where column D value is from 13 to 17 Oct 22.
blue will be 3 rows, where column D value is from 18 to 20 Oct 22.
There will be three section in the code.
The first is a loop which already mentioned in the answer of your question here.
The second and the third is additional code to involve the dtS and dtE.
Sub test()
Dim dtS As Date: Dim dtE As Date
Dim c As Range: Dim dif As Integer
Set c = Range("D2")
dtS = "02-Oct-22": dtE = "20-Oct-22"
'same code in https://stackoverflow.com/questions/75172779/vba-code-help-need-to-add-a-line-for-each-missing-date-and-copy-data-from-cell/75180868#75180868
Do While c.Offset(1, 0).Value <> ""
dif = DateDiff("d", c.Value, c.Offset(1, 0).Value)
If dif > 1 Then
With c.Offset(1, -3)
.EntireRow.Copy
Range(.Cells, .Offset(dif - 2, 0)).Insert Shift:=xlDown
End With
c.AutoFill Destination:=Range(c, c.Offset(dif - 1, 0)), Type:=xlFillDefault
Set c = c.Offset(dif, 0)
Else
Set c = c.Offset(1, 0)
End If
Loop
'check the dtS in column D first value
Set c = Range("D2")
If dtS < CDate(c.Value) Then
dif = DateDiff("d", dtS, c.Value): c.Value = dtS
With c.Offset(0, -3)
.EntireRow.Copy
Range(.Cells, .Offset(dif - 1, 0)).Insert Shift:=xlDown
End With
Set c = Range("D2")
c.AutoFill Destination:=c.Resize(dif + 1, 1), Type:=xlFillDefault
End If
'check the dtE in column D last value
Set c = Range("D2").End(xlDown)
If dtE > CDate(c.Value) Then
addr = c.Address: dif = DateDiff("d", c.Value, dtE)
With c.Offset(0, -3)
.EntireRow.Copy
Range(.Cells, .Offset(dif - 1, 0)).Insert Shift:=xlDown
End With
With Range(addr)
.AutoFill Destination:=.Resize(dif + 1, 1), Type:=xlFillDefault
End With
End If
End Sub
Again, the sub above is based on guessing from all of your three questions. Because in your first question, you don't mentioned about start date and end date at all. In the second question you mentioned :
Could someone help with rewriting the code so it adds all dates that
are missing between a start and end date. The start and end date would
need updated monthly so needs to be easily changed e.g. cells A2 and
B2 on the "Summary" worksheet
And in this question, you mentioned ONLY about the start date.
add the missing dates for the start of the month
Please note that the answer is based on the data in your second question, where your data is something like this
which your expected result is like this
Related
So I have a list of dates that I am trying to search through and check if they need to be corrected or not. The yellow highlighted cells are examples of changes needed to be made. Wether the date needs fixing or not I want the result of the code to place it in the "Date Fixed" column as shown in the first cell. If the date is not listed as the 30/31st of a month or the 1st then I need to change the day part of the date to either the beginning or end of the month. I have written what I thought would work but I keep receiving a Run Time Error 11 code. Any ideas on how to fix this and keep going through all the dates?
Private Sub FormatDate_Click()
Dim myrow As Integer
Dim startrow As Integer
Dim Dates As Date
Dim Datesfixed As Date
Dim dateTwo As Date
Dim dateEnd As Date
myrow = 2
startrow = 2
Dates = Cells(myrow, 2)
Datesfixed = Cells(myrow, 3)
dateTwo = mm / 1 / yyyy
dateEnd = mm / 31 / yyyy
Do Until Cells(myrow, 1) = ""
If Dates = dateTwo Or dateEnd Then
Datesfixed = Dates
ElseIf Dates <> dateTwo Or dateEnd Then
Dates = dateTwo
myrow = myrow + 1
End If
myrow = myrow + 1
Loop
myrow = 2
startrow = 2
End Sub
Try something like this:
Private Sub FormatDate_Click()
Dim c As Range, dt, d As Long, m As Long, y As Long, dLast As Long
Set c = ActiveSheet.Range("B2") 'first date
Do While Len(c.Value) > 0
dt = c.Value
d = Day(dt) 'extract the parts of the date
m = Month(dt)
y = Year(dt)
dLast = Day(DateAdd("m", 1, DateSerial(y, m, 1)) - 1) 'last day of the month
If d <> 1 And d <> dLast Then
c.Offset(0, 1) = DateSerial(y, m, dLast) 'set to last day of the month
End If
Set c = c.Offset(1, 0) 'next date
Loop
End Sub
I am trying to delete row based upon their values (i.e. if a cell contains the word DELETE) then the entire row should be deleted and shifted up.
I currently have code that loops through data and applies the cell value "IN-SCOPE" or "DELETE" to column 11 depending on the date present in Column 4. This works fine - however, the code I've written to delete any items labeled with "DELETE" doesn't do anything. Below is the code I currently have - any help would be great.
'Loop that lables items as in-scope IF they fall within the user defined range
y = 2
StartDate = Controls.Cells(15, 10).Value
EndDate = Controls.Cells(15, 11).Value
Bracknell.Activate
Cells(1, 11).Value2 = "Scope Check"
Do While Cells(y, 4).Value <> ""
If Cells(y, 9).Value >= StartDate And Cells(y, 9).Value < EndDate Then
Cells(y, 11).Value = "IN-SCOPE"
Else: Cells(y, 11).Value = "DELETE"
End If
y = y + 1
Loop
'Loop to delete out of scope items
Bracknell.Activate
z = 1
Do While Cells(z, 4).Value <> ""
If Cells(z, 11).Value = "DELETE" Then
Range("A" & z).EntireRow.Delete shift:=xlUp
End If
z = z + 1
Loop
Try this, the code is self explained:
Option Explicit
'use option explicit to force yourself
'to declare all your variables
Sub Test()
'Loop that lables items as in-scope IF they fall within the user defined range
Dim StartDate As Date
StartDate = Controls.Cells(15, 10).Value
Dim EndDate As Date
EndDate = Controls.Cells(15, 11).Value
With Bracknell
'Instead deleting every row, store them into a range variable
Dim RangeToDelete As Range
'Calculate your last row with data
Dim LastRow As Long
'Assuming your column 4 has data on all the rows
'If not, change that 4 for a column index that has data.
LastRow = .Cells(.Rows.Count, 4).End(xlUp).Row
'The most efficient way to loop through cells
'is using For Each loop
Dim cell As Range
.Cells(1, 11) = "Scope Check"
'loop through every row in column 4
For Each cell In .Range(.Cells(2, 4), .Cells(LastRow, 4))
'if the cell of that row in column 9 is between
If .Cells(cell.Row, 9) >= StartDate And .Cells(cell.Row, 9) < EndDate Then
.Cells(cell.Row, 11) = "IN-SCOPE"
Else
'if not, check if rangetodelete is empty
If RangeToDelete Is Nothing Then
'if it is empty, set it as the cell
Set RangeToDelete = cell
Else
'if not, set it as what it already is and the new cell
Set RangeToDelete = Union(RangeToDelete, cell)
End If
End If
Next cell
'Once you ended the loop you'll get the variable
'with every cell that didn't meet your criteria
'Check if is nothing, which means there are no cell to delete
If Not RangeToDelete Is Nothing Then RangeToDelete.EntireRow.Delete
End With
End Sub
I have a problem I hope I can get some help with. In a summary report I need to use date criterias: today's date compared to months in B1:M1 (all cells are date formatted using a userdefined date format to only display the monthname) to sum the rows of data only if an account number is listed in column A. (pls. see below example)
I.E. if todays date is Feb. 7th the VBA code should loop through all rows and only sum the numbers for January and february where an account # is present (it must be in VBA)
Here is what I have so far:
Sub Test()
Dim today, lastdayinmonth As Date
Dim i, ii As Integer
Dim months As Range
today = DateSerial(Year(Date), Month(Date), Day(Date))
lastdayinmonth = DateSerial(Year(Date), Month(Date) + 1, 0)
months = Sheet2.Range("B2:M2")
If idag <= lastdayinmonth Then
For i = 3 To 20
If Not IsEmpty(Sheet2.Range("B" & i)) Then
End If
Next ii
End If
End Sub
Try this code, please. It works based on the assumption that your columns header are Date formatted (no matter if they show only month...), and the sum will be returned in Imediate Window:
Sub TestSumMonth()
Dim arrM As Variant, i As Long, j As Long
Dim nSum As Long, lastRow As Long, sh As Worksheet
Set sh = sheet2
lastRow = sh.Range("A" & sh.Rows.count).End(xlUp).Row
arrM = sh.Range("A1:M" & lastRow).Value
sh.Range("O2:O" & lastRow).Interior.ColorIndex = xlNone ' clear the existing interior color
For i = 1 To UBound(arrM, 1)
If arrM(i, 1) <> Empty Then
nSum = 0
For j = 2 To UBound(arrM, 2)
If Month(Date) >= Month(arrM(1, j)) Then
nSum = nSum + arrM(i, j)
If Month(Date) = Month(arrM(1, j)) Then
With sh.Range("O" & i)
.Value = nSum
.Interior.Color = vbYellow ' interior colored in yellow
End With
Exit For
End If
End If
Next j
End If
Next i
End Sub
The code firstly clears "O:O" range interior color, then returns the sum on the appropriate row of this column and colors the cell interior in yellow...
Now, it would summarize all the passed month values plus the active month.
I am trying to insert a column based on a date in cell B1. I have various columns with dates in row 2; however, my supplied code throws off error 1004 when I run it. I believe this is due to the loop eventually running into a cell in row 2 that is empty, presumably because the date in cell B1 is more recent than all the other dates. How can I make it insert a column to the right of the last column with a date in this case?
Here is what I have so far as supplied by user "The GridLock":
Sub DateLoopTest()
Dim i As Integer
i = 0
'Loop from [B2] offset 0 to 1,2... -> then stop at [b2].offset(0,i)
Do Until (DateValue([b1]) < DateValue(IIf(IsDate([b2].Offset(0, i)), [b2].Offset(0, i), [b1])))
i = i + 1
Loop
[b2].Offset(0, i).EntireColumn.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
[b2].Offset(0, i).Value = [b1]
End Sub
It is best to use variables that mean something and avoid using brackets for the ranges. You can't test the logic if you can't identify the range. Your logic doesn't test if there is a date greater than your starting point or if the date already exists in the range. This is a starting point and you can modify to test other logic, but it won't give you an error.
Sub DateLoopTest()
Dim LC As Long
Dim MaxDate As Date
Dim TargetDate As Date
LC = Cells(2, Columns.Count).End(xlToLeft).Column
Dim HdrRng As Range
Set HdrRng = Range(Cells(2, 2), Cells(2, LC))
MaxDate = WorksheetFunction.Max(HdrRng)
TargetDate = Cells(1, 2)
i = 2
If TargetDate < MaxDate And WorksheetFunction.CountIf(HdrRng, TargetDate) = 0 Then
Do Until TargetDate > Cells(2, i)
i = i + 1
Loop
Cells(2, i).EntireColumn.Insert Shift:=xlToRight, copyorigin:=xlFormatFromLeftOrAbove
Cells(2, i).Offset(0, 1) = TargetDate
ElseIf WorksheetFunction.CountIf(HdrRng, TargetDate) > 0 Then
Z = HdrRng.Find(TargetDate).Column
Cells(2, Z + 1).EntireColumn.Insert Shift:=xlToRight, copyorigin:=xlFormatFromLeftOrAbove
Cells(2, Z + 1) = TargetDate
End If
End Sub
I am using a macro from this thread to insert new rows
but the problem is when there is the same start date as end date I get the
Error 1004
can you help modify the VBA to skip those lines that produce the Error?
is there an easy way how to fill in the column B (marked red) the consequential dates to complete the table (one day per line)?
Start Date End Date Hours Type
02-01-18 02-01-18 8 one day
04-01-18 04-01-18 4 half day
05-01-18 06-01-18 16 multiple days
07-01-18 10-01-18 16 multiple days
11-01-18 11-01-18 8 one day
UPDATE:
you can use an if command to check to see if the dates match, then only run the check if they dont. the code will now add every subsequent date between the start and end date
Public Sub AAA_Format()
Dim i As Long
Dim d As Long
Dim LastRow As Long
Dim j As Long
Dim rng As Range, rng2 As Range
Dim startrow As Long, insertedrow As Long
Application.CutCopyMode = False
With Worksheets("Data")
LastRow = .UsedRange.Rows.Count
For i = LastRow To 2 Step -1 '' starts at bottom and goes up, that way inserting rows doesn impact it
'checks to see if 2 values are the same
If Not Cells(i, "B") = Cells(i, "C") Then
Debug.Print Cells(i, "B")
Debug.Print Cells(i, "C")
d = DateDiff("d", .Cells(i, "B"), .Cells(i, "C")) '' find differene
Debug.Print d
insertedrow = i + d
.Rows(i + 1 & ":" & insertedrow).Insert Shift:=xlDown
End If
For j = 1 To d
.Cells(i + j, 2) = .Cells((i + j) - 1, 2) + 1
.Cells(i + j, 3) = "what ever you want to calc end date as"
.Cells(i + j, 4) = "what ever you want to calc hours as"
.Cells(i + j, 5) = "what ever you want to calc day as"
Next j
Next i
End With
End Sub
To insert a column you can use
ActiveSheet.Range("D:D").EntireColumn.Insert
and to add formula to it you can use
LastRow = ActiveSheet.Range("B" & ActiveSheet.Rows.Count).End(xlUp).Row '' this find bottom row by starting on very last row of sheet and moving up until it finds a cell with a value in it
Range("D2").Formula = "=IF(C2>0,C2,C1+1)"'' you might need to change , for ; depending on your language pack
Range("D2:D" & LastRow ).FillDown