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
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 would like populate the blue area with random numbers.
sum of C3 to R3 should be equal to B3 value: 124
also;
sum of C3 to C26 should be equal to C2 value: 705
I tried to achieve it with the following code:
(this code was originally posted here: Code by #Mech
Sub RandomNumbersArray()
' dim your variables. this tells vba what type of variable it is working with
Dim lRow As Long
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("SPLIT BY DAYS")
' find the last row in column b (2) in the above defined ws
lRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
' loop through rows 3 to last row
For i = 3 To lRow
' generate a random number between 0 and the row contents of column B (5)
ws.Cells(i, 3).Value = Int(Rnd() * (ws.Cells(i, 2).Value + 1))
' generate a random number between 0 and the difference between column B and colum C
ws.Cells(i, 4).Value = Int(Rnd() * (ws.Cells(i, 2).Value - ws.Cells(i, 3).Value))
' subtract the difference between column B and the sum of column C and column D
ws.Cells(i, 5).Value = ws.Cells(i, 2).Value - (ws.Cells(i, 3).Value + ws.Cells(i, 4).Value)
' subtract the difference between column B and the sum of column C and column D and column E
ws.Cells(i, 6).Value = ws.Cells(i, 2).Value - (ws.Cells(i, 3).Value + ws.Cells(i, 4).Value + ws.Cells(i, 5).Value)
' subtract the difference between column B and the sum of column C and column D and column E and column F
ws.Cells(i, 7).Value = ws.Cells(i, 2).Value - (ws.Cells(i, 3).Value + ws.Cells(i, 4).Value + ws.Cells(i, 5).Value + ws.Cells(i, 6).Value)
Next i
' sum column C (column 3) and place the value in C2
ws.Cells(2, 3).Value = Application.WorksheetFunction.Sum(Range(Cells(3, 3), Cells(lRow, 3)))
' sum column D (column 4) and place the value in D2
ws.Cells(2, 4).Value = Application.WorksheetFunction.Sum(Range(Cells(3, 4), Cells(lRow, 4)))
' sum column E (column 5) and place the value in E2
ws.Cells(2, 5).Value = Application.WorksheetFunction.Sum(Range(Cells(3, 5), Cells(lRow, 5)))
' sum column F (column 6) and place the value in F2
ws.Cells(2, 6).Value = Application.WorksheetFunction.Sum(Range(Cells(3, 6), Cells(lRow, 6)))
' sum column G (column 7) and place the value in F2
ws.Cells(2, 7).Value = Application.WorksheetFunction.Sum(Range(Cells(3, 7), Cells(lRow, 7)))
End Sub
EDIT: Just to clarify, no negative numbers.
Here is something to try:
Set all cells to 0. Create a list of all cells (some kind of reference to each cell).
Now, randomly choose a cell from your list, and add 1 to that cell. The very first time, all cells will be 0, except for one, which will now be 1.
For this cell that you just incremented, add up the row and column and see if the sums have been reached. If either the row or the column sum has been reached, remove this cell reference from the list.
Repeat (randomly choose a cell from those remaining on the list) until the list is empty.
At each iteration you are randomly choosing one of the remaining cells in the reference list (not choosing from all the cells) and this list is getting smaller and smaller as column or row sums are reached.
It should be the case that random cells will increment, and if the columns and sums can in fact be calculated by values without logical inconsistencies, you should fairly quickly reach that point when the reference list falls empty.
I have a solution.
Answers so far have mostly been about finding values which are random, then fixing them to fit the totals.
I tried finding a calculated (non random) solution that fits the totals, then made a separate sub to randomize it. This way you can prevent the randomization from introducing negative values.
There are two procedures, This sub will call them both on the same Range.
Sub Call_Random_Array
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("SPLIT BY DAYS")
Dim RangeToFill as Range: Set RangeToFill = ws.Range("C3:R26") 'Edit this line to select whatever range you need to fill randomly
'Proportionately fill the array to fit totals:
Call ProportionateFillArray(RangeToFill)
'Randomize it x times
For x = 1 to 10 'increase this number for more randomisation
Call RandomizeValues(RangeToFill)
Next
End Sub
Proportionately fill the array to fit totals:
Sub ProportionateFillArray(rngAddress As Range)
Dim ws As Worksheet: Set ws = rngAddress.Worksheet
'Horizontal and Vertical target values as ranges:
Dim hTarg As Range, vTarg As Range
Set hTarg = rngAddress.Rows(1).Offset(-1, 0)
Set vTarg = rngAddress.Columns(1).Offset(0, -1)
'Check the totals match
If Not WorksheetFunction.Sum(hTarg) = WorksheetFunction.Sum(vTarg) Then
'totals don't match
MsgBox "Change the targets so both the horizontal and vertical targets add up to the same number."
Exit Sub
End If
With rngAddress
'Now fill rows and columns with integers
Dim Row As Long, Col As Long
For Row = 1 To .Rows.Count
For Col = 1 To .Columns.Count
.Cells(Row, Col) = Int( _
hTarg.Cells(Col) * vTarg.Cells(Row) / WorksheetFunction.Sum(hTarg) _
)
Next
Next
'Correct rounding errors
For Row = 1 To .Rows.Count
For Col = 1 To .Columns.Count
If Row = .Rows.Count Then
'Last row, so this column must be corrected come what may
.Cells(Row, Col) = .Cells(Row, Col) - WorksheetFunction.Sum(.Columns(Col)) + hTarg.Cells(Col)
ElseIf Col = .Columns.Count Then
'Last column, so must be corrected come what may
.Cells(Row, Col) = .Cells(Row, Col) - WorksheetFunction.Sum(.Rows(Row)) + vTarg.Cells(Row)
ElseIf _
(WorksheetFunction.Sum(.Rows(Row)) - vTarg.Cells(Row)) * _
(WorksheetFunction.Sum(.Columns(Col)) - hTarg.Cells(Col)) > 0 Then
'both row and column are incorrect in the same direction
.Cells(Row, Col) = .Cells(Row, Col) - WorksheetFunction.Max( _
WorksheetFunction.Sum(.Rows(Row)) - vTarg.Cells(Row), _
WorksheetFunction.Sum(.Columns(Col)) - hTarg.Cells(Col))
End If
Next
Next
End With
End Sub
Randomize an array without changing row or column totals:
Sub RandomizeValues(rngAddress As Range)
Dim ws As Worksheet: Set ws = rngAddress.Worksheet
Dim rngIncrease(1 To 2) As Range, rngDecrease(1 To 2) As Range, lDiff As Long
With rngAddress
'Select two cells to increase at random
For a = 1 To 2
Set rngIncrease(a) = .Cells(RndIntegerBetween(1, .Rows.Count), RndIntegerBetween(1, .Columns.Count))
rngIncrease(a).Select
Next
'Corresponding cells to decrease to make totals the same:
Set rngDecrease(1) = ws.Cells(rngIncrease(1).Row, rngIncrease(2).Column)
Set rngDecrease(2) = ws.Cells(rngIncrease(2).Row, rngIncrease(1).Column)
'Set the value to increase/decrease by - can't be more than the smallest rngDecrease Value, to prevent negative values
If Not WorksheetFunction.Min(rngDecrease) > 1 Then
'Don't decrease a value below 1
Exit Sub
Else
lDiff = RndIntegerBetween(1, WorksheetFunction.Min(rngDecrease)-1)
End If
'Now apply the edits
For a = 1 To 2
rngIncrease(a) = rngIncrease(a) + lDiff
rngDecrease(a) = rngDecrease(a) - lDiff
Next
End With
End Sub
'The below is the Random Integer function, I also used it in my other answer
Function RndIntegerBetween(Min As Long, Max As Long) As Long
RndIntegerBetween = Int((Max - Min + 1) * Rnd + Min)
End Function
This code is for what you were trying to do, not exactly how you explained it though (see comments). If this is what you were looking for, then your explanation was a bit off, otherwise let me know what you did mean.
Sub RandomNumbersArray()
Dim lRow As Long, lColumn As Long, remainingValue As Long
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("SPLIT BY DAYS")
lRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
lColumn = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column
For i = 3 To lRow 'loop through the rows
remainingValue = ws.Cells(i, 2).Value2
For j = 3 To lColumn 'loop through all the columns per row
' generate a random number between 0 and the row contents of column B - previous column
If j = lColumn Then 'last cell can't be random unless you want to extend the columns until the sum in B-column is met
ws.Cells(i, j).Value2 = remainingValue
Else
ws.Cells(i, j).Value2 = Int((remainingValue + 1) * Rnd)
End If
remainingValue = remainingValue - ws.Cells(i, j).Value2
Next j
Next i
For j = 3 To lColumn 'loop through the columns to set the sum
ws.Cells(2, j).Value2 = Application.WorksheetFunction.Sum(Range(Cells(3, j), Cells(lRow, j)))
Next j
End Sub
I'm yet to get past the O-column with any value above 0 however
Variance Table Sample I'm working on an Excel Macros (VBA) to look through every 3rd cell of each row in a data set and perform a copy paste action based on conditions (Please see the code at the bottom).
The source data is in a another worksheet (Variance). It has 1300+ IDs (rows) and 3 columns for each value component (col 1 - value 1, col 2 - value 2, and col 3 - the difference between the 2 values) and likewise there are 500+ columns.
My code basically looks through every third column (the difference column) of each row to find out if the value is a number, not equal to zero, and if it's not an error (there are errors in the source sheet). If yes, it copies the Emp ID, the column Name, and both the values into another worksheet called vertical analysis (one below the other).
The code works fine, but it takes 6 to 7 minutes for a data set with 1000+ rows and 500+ columns.
Can someone please tell me if there is a faster way to do this than to loop through each row?
Please let me know if you need more information. Thanks in advance.
Code:
Sub VerticalAnalysis()
Dim EmpID As Range
Dim i As Long
Dim cell As Range
Dim lastrow As Range
Dim LastCol As Long
Dim curRow As Long
Dim c As Long
Set lastrow = ThisWorkbook.Worksheets("Variance").Cells(Rows.Count, 2).End(xlUp)
Set EmpID = ThisWorkbook.Worksheets("Variance").Range("B4", lastrow)
LastCol = ThisWorkbook.Worksheets("Variance").Cells(3, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
MsgBox "Depending on the size of the record, your excel will not respond for several minutes during Vertical Analysis. Please don't close the workbook", , "Note: Please Don't Close the Workbook"
Worksheets("Vertical").Select
Range("B3", "H" & Rows.Count).ClearContents
Range("B3", "H" & Rows.Count).ClearFormats
ThisWorkbook.Worksheets("Variance").Select
c = 1
For Each cell In EmpID
i = 2
Do Until i >= LastCol
cell.Offset(0, i).Select
If IsError(ActiveCell) Then
ElseIf ActiveCell <> "" Then
If IsNumeric(ActiveCell) = True Then
If ActiveCell <> 0 Then
cell.Copy
Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(-c, -2).Copy
Worksheets("Vertical").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -2).Copy
Worksheets("Vertical").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -1).Copy
Worksheets("Vertical").Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End If
End If
i = i + 4
Loop
c = c + 1
Next cell
ThisWorkbook.Worksheets("Vertical").Select
Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Row - 2 & " Components have variations", , "Success!"
Application.ScreenUpdating = True
End Sub
You might try to use SQL. In order to learn how to use sql in EXCEL VBA, I suggest you to follow this tuto and to apply your learn on your macro. They will be faster =)
https://analystcave.com/excel-using-sql-in-vba-on-excel-data/
Better not to hit the sheet so many times.
Below is tested and should run in a few seconds, but you may need to tweak the column positions etc:
Sub VerticalAnalysis()
Const BLOCK_SIZE As Long = 30000
Dim lastrow As Long
Dim LastCol As Long
Dim c As Long, wsVar As Worksheet, wsVert As Worksheet, n As Long
Dim data, r As Long, empId, v, rwVert As Long, dataVert, i As Long
Set wsVar = ThisWorkbook.Worksheets("Variance")
Set wsVert = ThisWorkbook.Worksheets("Vertical")
lastrow = wsVar.Cells(Rows.Count, 2).End(xlUp).Row
LastCol = wsVar.Cells(3, Columns.Count).End(xlToLeft).Column
'get all the input data as an array (including headers)
data = wsVar.Range("A3", wsVar.Cells(lastrow, LastCol)).Value
'clear the output sheet and set up the "transfer" array
With wsVert.Range("B3", "H" & Rows.Count)
.ClearContents
.ClearFormats
End With
rwVert = 3 'first "vertical" result row
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4) 'for collecting matches
i = 0
n = 0
For r = 2 To UBound(data, 1) 'loop rows of input array
empId = data(r, 2) 'colB ?
c = 7 'first "difference" column ?
Do While c <= UBound(data, 2)
v = data(r, c)
If Not IsError(v) Then
If IsNumeric(v) Then
If v > 0.7 Then
i = i + 1
n = n + 1
dataVert(i, 1) = empId
dataVert(i, 2) = data(1, c) 'header
dataVert(i, 3) = data(r, c + 2) 'value1
dataVert(i, 4) = data(r, c + 1) 'value2
'have we filled the temporary "transfer" array?
If i = BLOCK_SIZE Then
wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
i = 0
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4)
rwVert = rwVert + BLOCK_SIZE
End If
End If
End If
End If
c = c + 4 'next difference
Loop
Next r
'add any remaining
If i > 0 Then wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
wsVert.Select
wsVert.Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & n & " Components have variations", , "Success!"
End Sub
I have the following input data:
I need to populate each entry into 3 rows with different payout rates & periods, something like this:
Thecommission payout is based on the following rates:
i) 1st month - 50%
ii) 2nd month - 30%
iii) 3rd month - 20%
Example:-
The next criteria is the commission payout period. The current month collection will be paid in the following months.
How can I do it using a Excel & macro?
Thanks.
Assuming your data is on the 1st sheet, create a second sheet and run this macro:
Option Explicit
Sub popData()
Dim r As Integer, r2 As Integer, p As Integer: r2 = 3
Dim sht2 As Worksheet: Set sht2 = Sheets(2)
Dim rate(), headings()
rate = Array(0.5, 0.3, 0.2)
headings = Array("Date", "Sales", "Commission", "Collection Date", "Invoice No")
For r = 0 To UBound(headings):
sht2.Cells(2, r + 1).Value = headings(r)
Next
Dim dat As Date
With Sheets(1)
sht2.Cells(1, 1).Value = "Payout"
For r = 3 To .Cells(.Rows.Count, "A").End(xlUp).row:
For p = 0 To 2:
sht2.Cells(r2, "A").NumberFormat = .Cells(r, "A").NumberFormat
dat = DateAdd("m", p + 1, CDate(.Cells(r, "A")))
sht2.Cells(r2, "A").Value = DateSerial(year(dat), month(dat) + 1, 0)
sht2.Cells(r2, "B").Value = .Cells(r, "B").Value
sht2.Cells(r2, "C").NumberFormat = "0.00"
sht2.Cells(r2, "C").Value = .Cells(r, "C").Value * rate(p)
sht2.Cells(r2, "D").NumberFormat = .Cells(r, "A").NumberFormat
sht2.Cells(r2, "D").Value = .Cells(r, "A").Value
sht2.Cells(r2, "E").Value = .Cells(r, "D").Value
r2 = r2 + 1
Next
Next
End With
sht2.Columns("A:E").EntireColumn.AutoFit
End Sub
The first loop adds the headers to the 2nd sheet. The next double loop processes each salesperson with the inner loop creating the 3 rows for each commission payout. It appears that you want the last day of the next month - which is provided for by adding a month to the present date and then using the DateSerial function to find the last day of that month. The last line just ensures all the columns are expanded to their largest text entry so everything is visible.
This is the macro i am using, it looks at a field (AS) and then depending on the number in that column it will create the same amount of rows underneath. So for example if AS has '4' it will create 4 rows containing the number 4.
I need an amendment to this so that these rows will show 1-4, 2-4, 3-4, 4-4
Sub addlabels()
Dim r As Long
For r = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(r, "AS") > 1 Then
Cells(r, 1).EntireRow.Copy
Cells(r + 1, 1).EntireRow.Resize(Cells(r, "AS").Value - 1).Insert shift:=xlDown
End If
Next r
End Sub
Here is an example image of how i need the column to display at the moment it just simply copies from the top field http://i.stack.imgur.com/p8bl8.png
May be you can try like this:
Considering the field("AS") is in cell a1 i've used the following code:
Sub addinglabels()
Dim i As Integer
cellvalue = ActiveSheet.Range("A1").Value
If (cellvalue > 1) Then
For i = 1 To cellvalue
Cells(i + 1, 1).Value = i & "--" & cellvalue
Next i
End If
End Sub