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
Related
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
I've got dates in Row 2 and have the following code to insert a column based on whether the date in B1 is less than the date in B2, C2, etc....
Sub Test3()
If DateValue(Cells(1, 2).Value) < DateValue(Cells(2, 2).Value) Then
Range("B2").EntireColumn.Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(2, Selection.Column).Select
ActiveCell.Value = Range("B1")
ElseIf DateValue(Cells(1, 2).Value) < DateValue(Cells(2, 3).Value) Then
Range("C2").EntireColumn.Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(2, Selection.Column).Select
ActiveCell.Value = Range("B1")
End If
End Sub
The above code works and adds a column at the right place and puts a date in row 2 of the column.
Obviously it would be much easier for me to loop this but I am having trouble getting the loop to work. Here is what I have so far:
Sub DateLoopTest()
Dim i As Integer
i = 1
Do Until DateValue(Cells(1, 2).Value) < DateValue(Cells(2, i + 1).Value)
Cells(2, i + 1).EntireColumn.Select
i = i + 1
Loop
ActiveCell.EntireColumn.Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(2, Selection.Column).Select
ActiveCell.Value = Range("B1")
End Sub
I am getting Run-Time error '13': Type mismatch
No matter how much I mess with it I can't get it to loop like I want in my 1st example. Any suggestions
you can refer to this code:
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
maybe i got it wrong because i'm just looking at your code, try this again, hope it helps :)
Sub DateLoopTest1()
Dim i As Integer, isCellhere As Boolean, isExistCell As Boolean, isRecentday As Boolean: i = 0:
isRecentday = True
'get lastCell index for Loop
Dim iLast As Integer: iLast = Cells(2, 15000).End(xlToLeft).Column
Dim iMax As Integer: iMax = 2 'default
Dim Cellmax As Range: Set Cellmax = [b2] 'default
Dim Datedefault As Variant: Datedefault = #1/1/1000#
If iLast = 1 Then Exit Sub
'Loop until CellMax
For i = 0 To iLast - 2
isCellhere = Datedefault < DateValue(IIf(IsDate([b2].Offset(0, i)), [b2].Offset(0, i), Datedefault))
'stop if True
If isCellhere Then Set Cellmax = [b2].Offset(0, i): Datedefault = DateValue([b2].Offset(0, i).Value)
Next i
Cellmax.EntireColumn.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cellmax.Offset(0, -1).Value = [b1]
End Sub
I am trying to make a loop that prints every value between two cells in a row into a single column. I would also like it to skip/ignore non integer values.
For example: Cell A5 contains 5673 and Cell B5 contains 5677. Therefore the macro would output 5673, 5674, 5675, 5676, and 5677.
I have found some useful examples for looping through each row and printing each value, but have not been able to combine the two.
To print each value between the two numbers:
[D1] = [A1].Value
ato = [B1].Value
[D1].DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Stop:=ato
To loop through every row:
LR = Range("A" & Rows.Count).End(xlUp).Row
For j = 1 To LR
Cells(j, 1).Offset(0, 2).Value = ***Every cell value between Cells(j, 1) and Cells(j, 2)***
Next j
Before:
Desired after:
Try this. You can use SpecialCells to pick out the numerical cells, and Fill to produce the intervening sequences.
Sub x()
Dim rA As Range, rCell As Range
For Each rA In Columns(1).SpecialCells(xlCellTypeConstants, xlNumbers).Areas
For Each rCell In rA
Range("D" & Rows.Count).End(xlUp)(2).Value = rCell.Value
Range("D" & Rows.Count).End(xlUp).DataSeries Rowcol:=xlColumns, Step:=1, Stop:=rCell.Offset(, 1), Trend:=False
Next rCell
Next rA
End Sub
If you will always have these 2 columns, then you may use this code
for j = 1 to 2:for i = 1 to cells(rows.count,j).end(xlup).row
if isnumeric(cells(i,j)) then cells(rows.count,4).end(xlup).offset(1,0) = cells(i,j)
next:next
bear in mind that it will post everysingle number, if you need to delete duplicates, you may do it using range.removeduplicate
Loop through the range cell by cell; test for IsNumeric and Duplicate values. Note: this is just a test code, you should always add workbook and worksheet references
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To 2
If IsNumeric(Cells(i, j)) And Cells(i, j).Offset(, 1).Value <> Cells(i, j).Value Then
If IsEmpty(Cells(1, 4).Value) Then
Cells(1, 4) = Cells(i, j)
Else: Cells(Rows.Count, 4).End(xlUp).Offset(1) = Cells(i, j)
End If
End If
Next j
Next i
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
My code mostly works but it's taking a while to debug so I am beginning to think my architecture may be flawed XD So how can I architect this better?
I have groups of data separated by a blank row. You can tell each group apart by the ID in column C in addition to the blank row. For each ID, I have various numbers in column B that I need to capture. Sometimes those numbers only start with 5, sometimes it starts with 7. I need to capture the 5 and the 7 separately.
With projWS
With .Range("C1:C6000")
Set f = .Find(cc, LookIn:=xlValues, lookat:=xlPart)
End With
If Not f Is Nothing Then 'first occurence found
counter = 0
i = f.Row
Do
acct = .Cells(i, 2)
If (Len(projWS.Cells(i, 3)) < 1 Or Left(acct, 1) = "7") And done = False Then
acctStart = f.Row
acctRows = i - acctStart
Set acctRng = .Range(.Cells(acctStart, 2), .Cells(i - 1, 5))
Set amountRng = .Range(.Cells(acctStart, 7), .Cells(i - 1, 8))
done = True 'set flag to show range has been filled
End If
counter = counter + 1 'increment counter
i = i + 1 'move to next row
Loop Until Len(.Cells(i, 3)) < 1 'keep looping until blank row
End If
If counter - 1 > acctRows Then 'how we determine if there's a "7"
flag = True 'so we set flag to true
Set depreRng = Range(.Cells(acctStart + acctRows, 2), .Cells(i - 1, 8))
dep = depreRng.Value2 'store range into array
End If
End With
After capture, I need to drop it into another worksheet. This worksheet already has a block of 7 built in. Hence this is the loop I am using to drop the range of 7. There is no built in block for the 5.
For r = 112 To 120
For k = 1 To UBound(dep())
If .Cells(r, 1).Value2 = Trim(dep(k, 1)) Then
Debug.Print .Cells(r, 1).Value2
.Cells(r, 6) = dep(k, 6)
.Cells(r, 7) = dep(k, 7)
Exit For
Else
.Cells(r, 6) = 0
.Cells(r, 7) = 0
End If
Next k
Next r
I have debugged several errors already. The current one is that depreRng is breaking because my math is bad. Instead of debugging each error as I stumble onto it, how can I architect this better?
Ok, my approach it's different. First i use a filter for find the range of rows with the index you are looking for and then loop inside this filtered rows for find the 5xx and the 7xx range. The code:
Sub Macro1()
Dim rng_5xx_start, rng_5xx_stop, rng_7xx_start, rng_7xx_stop As Integer
rng_5xx_start = 0
rng_5xx_stop = 0
rng_7xx_start = 0
rng_7xx_stop = 0
Dim range_5xx, range_7xx As String
'filter for the index you are looking for
'specify the maximum range, the field is the "offset" from the column B (the firts of the range), so for filter for column C you need to put 2, criteria...is the critera :)
ActiveSheet.Range("$B$1:$H$6000").AutoFilter Field:=2, Criteria1:="b"
'the filter returns only the rows with the specifyed index, now a for inside this rows for find the 5xx and the 7xx sub-ranges
For Each Row In ActiveSheet.Range("b1:b6000").SpecialCells(xlCellTypeVisible)
If Cells(Row.Row, 2).Value > 4999 And Cells(Row.Row, 2).Value < 6000 Then
'or any test for understnd if i'm in the 5xx range, if you prefer use the strings use something like left(cells(row.row,2).value,1) = "5"
If rng_5xx_start = 0 Then 'found the first row with a 5xx value
rng_5xx_start = Row.Row 'set the start of the range to this row
End If
If rng_5xx_stop < Row.Row Then 'the row where i am is in the 5xx range and is grater than the current end i noticed
rng_5xx_stop = Row.Row 'refresh the end of the range...at the end this will have the last number of row of the 5xx range
End If
End If
If Cells(Row.Row, 2).Value > 6999 And Cells(Row.Row, 2).Value < 8000 Then
'same as above but for 7xx range
If rng_7xx_start = 0 Then
rng_7xx_start = Row.Row
End If
If rng_7xx_stop < Row.Row Then
rng_7xx_stop = Row.Row
End If
End If
Next
If rng_5xx_start = 0 Then
'not found 5xx rows
range_5xx = "" 'or False, or what you prefer...
Else
range_5xx = "B" & rng_5xx_start & ":H" & rng_5xx_stop
End If
If rng_7xx_start = 0 Then
'not found 7xx rows
range_7xx = "" 'or False, or what you prefer...
Else
range_7xx = "B" & rng_7xx_start & ":H" & rng_7xx_stop
End If
End Sub
That's how i would imagine a macro for your job ;)
Edit 1:
I forgot that this will leave the sheet with the filter on...use activesheet.showalldata for show all the rows and not only the filtered ones
Edit 2:
The tests
If rng_5xx_stop < Row.Row Then
rng_5xx_stop = Row.Row
End If
and
If rng_7xx_stop < Row.Row Then
rng_7xx_stop = Row.Row
End If
are not necessary, it's enough do rng_5xx_stop = Row.Row and rng_7xx_stop = Row.Row and save the two IF statements
You are grouping cells based on the first number of the cell values in column B (I am assuming that they can never be letters). If that is the case, then you can create an array of 0 to 9 and store your ranges in there. Then go through the range.areas in order to get the groupings you're looking for (as highlighted in your screenshot).
To do this, something like this is all you need. I commented code to try to explain it more:
Sub tgr()
Dim wsData As Worksheet
Dim rColB As Range
Dim BCell As Range
Dim aRanges(0 To 9) As Range
Dim SubGroup As Range
Dim lRangeNum As Long
Dim i As Long
'Change to your actual worksheet
Set wsData = ActiveWorkbook.ActiveSheet
'Change to your actual column range, this is based off the sample data
Set rColB = wsData.Range("B1", wsData.Cells(wsData.Rows.Count, "B").End(xlUp))
'Loop through the column range
For Each BCell In rColB.Cells
'Make sure the cell is populated and the starting character is numeric
If Len(BCell.Value) > 0 And IsNumeric(Left(BCell.Value, 1)) Then
'Get the starting digit
lRangeNum = Val(Left(BCell.Value, 1))
'Check if any ranges have been assigned to that array index location
'If not, start a range at that array index
'If so, combine the ranges with Union
Select Case (aRanges(lRangeNum) Is Nothing)
Case True: Set aRanges(lRangeNum) = BCell
Case Else: Set aRanges(lRangeNum) = Union(aRanges(lRangeNum), BCell)
End Select
End If
Next BCell
'You can use any method you want to access the ranges, this just loops
'through the array indices and displays the range areas of each
For i = 0 To 9
If Not aRanges(i) Is Nothing Then
For Each SubGroup In aRanges(i).Areas
'Do what you want with it here
'This just selects the subgroup so you can see it found the groups properly
SubGroup.Select
MsgBox SubGroup.Address
Next SubGroup
End If
Next i
End Sub
I see you've allready rewritten your code, but I'd like to offer how I would do it and would like to know your thoughts about it. Would this be inefficient? I guess it could be because you have to read the first character in cells 4 times for every increment, but not shure if that is a big problem.
Dim start_row As Long
Dim end_row As Long
start_row = 1
end_row = 0
For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
If Cells(i - 1, 2) = "" Then
start_row = i
ElseIf Left(Cells(i - 1, 2), 1) <> Left(Cells(i, 2), 1) Then
start_row = i
End If
If Cells(i + 1, 2) = "" Then
end_row = i
ElseIf Left(Cells(i + 1, 2), 1) <> Left(Cells(i, 2), 1) Then
end_row = i
End If
If end_row <> 0 Then
Call copy_range(start_row, end_row)
end_row = 0
End If
Next i
Another approach that lets you only read the character once could be
Dim start_row As Long
Dim end_row As Long
Dim char_above As String
Dim this_char As String
start_row = 1
end_row = 1
For i = 1 To Range("B" & Rows.Count).End(xlUp).Row
If Cells(i, 2) = "" Then
end_row = i - 1
if i <>1 then Call copy_range(start_row, end_row,char_above)
start_row = i + 1
Else
this_char = Left(Cells(i, 2), 1)
If this_char <> char_above Then
end_row = i - 1
if i<> 1 then Call copy_range(start_row, end_row,char_above)
start_row = i
End If
char_above = this_char
End If
Next i
Let me know your thoughts.