How to recursively copy a row every 15 rows in Microsoft Excel?-CodePudding

I have an excel sheet with 10,000 rows. Say a personal budget and expense tracker. It tracks my income and expenses on a weekly basis. I am paid every 15 days. So i want to recursively add a static row in my excel sheet for every 10 or 15 rows which looks something like this below

I want the income row to be repeatedly pasted (say) every 10 rows automatically. I don't want to do it manually.

Please advise if this can be automated.

CodePudding user response：

Here's a starter for you:

Sub createsheet()
    Dim wk As Long, r As Long, e As Long
    Dim wsh As Worksheet
    
    Set wsh = ActiveSheet
    r = 1
    e = 1
    
    For wk = 1 To 52
    
        wsh.Cells(r, 1).Value = "Week" & wk
        
        wsh.Cells(r   1, 1).Value = "Starting Balance"
        
        If wk = 1 Then
            wsh.Cells(r   1, 2).Value = 0
        Else
            wsh.Cells(r   1, 2).FormulaR1C1 = "=R[-2]C"
        End If
        
        wsh.Cells(r   2, 1).Value = "Income"
        wsh.Cells(r   2, 2).Value = 1000 ' remove if to be manually input
        
        wsh.Cells(r   3, 1).Value = "Expense " & e
        
        wsh.Cells(r   4, 1).Value = "Expense " & e   1
        
        e = e   2
        
        wsh.Cells(r   5, 1).Value = "Ending Balance"
        wsh.Cells(r   5, 2).FormulaR1C1 = "=SUM(R[-4]C:R[-1]C)"
        r = r   6
        
    Next
    
End Sub

Run this on a new worksheet and add some conditional formatting to produce the colouring your require.

CodePudding user response：

Please, try the next code. I played with a range built based on an array created on the fly:

Sub CopyRowAtConstVal()
 Const rW As Long = 10   'The interval of the copying the range
 Const frstR As Long = 2 'row to be copied
 Dim sh As Worksheet, lastR As Long, arr, rng

 Set sh = ActiveSheet 'use here the sheet you need
 lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row in A:A column
 
 'build an array for the set interval:
 arr = Evaluate("TRANSPOSE(ROW(1:" & Int(lastR / (rW   1)) & ")*" & rW   1 & ")")
 
 Set rng = sh.Range("A" & Join(arr, ",A")) 'the range obtained from the above array (cells in A:A)
 sh.rows(frstR).Copy rng.Offset(frstR)     'copy the row to be copied (`frstR`) in the discontinuous entire row range...
End Sub

The above solution is a little fancy... It has a limitation of the maximum 255 characters of the discontinuous range address ("A" & Join(arr, ",A"), but it can be solved testing its Len and if the limitation has bee exceeded, a Union range can be easily set/build using the array elements.