Add Multiple Rows to Differing Variables

Good Morning,

I am trying get a VBA code that will add multiple rows given the amount of weeks between a date. I have attached an example spreadsheet with the original data that I have, and also what I require.

Basically if a row has six weeks between a loan of an item, I need 5 rows inserted with the start date and end date of each week between the loan period, with the rest of the cells remaining the same. The next loan is then say 5 weeks, so I need 4 lines inserted with the start week and and week changed. I guess the support ID in the example is the constat that will differentiate each loan period.

This is required so I can graph the qty of the loans over a period i.e monthly, 3 monthly or my choice of period. I am hoping the example is self explanatory, if not, I can try and clarify more if you have questions.

Kind Regards

Matthew

Go to the VBA IDE (alt-F11), insert a new module, and paste in this code:

Public Sub InsertMonthlyRows()

    Dim rngCurr         As Excel.Range

    Dim arrValues       As Variant

    Dim lngLastRow      As Long
    Dim lngCurrRow      As Long
    Dim intMonths       As Integer

    Set rngCurr = Worksheets("Sheet1").Range("A3")
    lngLastRow = rngCurr.Parent.Columns(1).Find(What:="*", After:=[A1], _
        SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
        LookAt:=xlPart, LookIn:=xlValues).Row
    arrValues = rngCurr.Resize(lngLastRow - rngCurr.Row + 1, 13)
    For lngCurrRow = UBound(arrValues) To LBound(arrValues) Step -1
        If arrValues(lngCurrRow, 12) > 0 _
        And arrValues(lngCurrRow, 13) > 0 Then
            intMonths = Year(arrValues(lngCurrRow, 13)) + Month(arrValues(lngCurrRow, 13)) _
                - Year(arrValues(lngCurrRow, 12)) - Month(arrValues(lngCurrRow, 12))
            rngCurr.Offset(lngCurrRow, 1).Resize(intMonths, 1).EntireRow.Insert xlShiftDown
            rngCurr.Offset(lngCurrRow - 1, 0).Resize(1, 1).EntireRow.Copy _
                Destination:=rngCurr.Offset(lngCurrRow - 1, 0).Resize(intMonths + 1, 1).EntireRow
        End If
    Next lngCurrRow

    Set rngCurr = Nothing
        
End Sub

You can call it with a command button or assign it to a ctrl-key combo. It starts at the bottom of the sheet, looking for entries with start and end dates. When it finds them, it calculates how many new rows are needed, inserts them, then copy/paste the source row to them. I'm not quite sure what you want to do with the entries at the bottom that don't have start and end dates, and you won't be able to run the macro more than once over the same data set.

The undated entries could be moved to a location lower in the sheet, if you want.

Wallyeye,

Thank you for your code. It was my mistake in the attached sheet, those entries with no dates should have been deleted. This is almost what I need, I am now trying to play with the code to insert the number of weeks, instead of months. I assume this will be just changing the code to look at colums L and M, instead of N and O??? I think.

I think once I get the right number of lines inserted, I will manually put in the start and end dates for the week, instead of trying to code it in.

Eg: date range is 07/05/12 till 21//05/12, this is two weeks, so I need two lines inserted. with the 1st inserted line date to be 14/05/12 and second line being 21/05/12. If you get my drift

Cheers though for the code, great start to what I require.

Actually, all you need to do is change the intMonths calculation to an intWeeks calc:

Public Sub InsertMonthlyRows()

    Dim rngCurr         As Excel.Range

    Dim arrValues       As Variant

    Dim lngLastRow      As Long
    Dim lngCurrRow      As Long
    Dim intWeeks        As Integer

    Set rngCurr = Worksheets("Sheet1").Range("A3")
    lngLastRow = rngCurr.Parent.Columns(1).Find(What:="*", After:=[A1], _
        SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
        LookAt:=xlPart, LookIn:=xlValues).Row
    arrValues = rngCurr.Resize(lngLastRow - rngCurr.Row + 1, 13)
    For lngCurrRow = UBound(arrValues) To LBound(arrValues) Step -1
        If arrValues(lngCurrRow, 12) > 0 _
        And arrValues(lngCurrRow, 13) > 0 Then
            intWeeks = Int((arrValues(lngCurrRow, 13) - arrValues(lngCurrRow, 12)) / 7) - 1
            rngCurr.Offset(lngCurrRow, 1).Resize(intWeeks, 1).EntireRow.Insert xlShiftDown
            rngCurr.Offset(lngCurrRow - 1, 0).Resize(1, 1).EntireRow.Copy _
                Destination:=rngCurr.Offset(lngCurrRow - 1, 0).Resize(intWeeks + 1, 1).EntireRow
        End If
    Next lngCurrRow

    Set rngCurr = Nothing
        
End Sub

Thanks,

I am getting a runtime error on this lin

intWeeks = Int((arrValues(lngCurrRow, 13) - arrValues(lngCurrRow, 12)) / 7) - 1

Cant seem to get passed it

Originally Posted by mattyh77

Thanks,

I am getting a runtime error on this lin

intWeeks = Int((arrValues(lngCurrRow, 13) - arrValues(lngCurrRow, 12)) / 7) - 1

Cant seem to get passed it

I've finally managed to figure it out.

Cheers for your help