这里有一个为您准备的启动程序：

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

在一个新的工作表上运行这个程序，并添加一些条件格式来产生你需要的颜色。

请尝试下一个代码。我使用了一个动态创建的数组构建了一个虚拟范围：

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

上面的解决方案有点花哨......它限制不连续范围地址("A" & Join(arr, ",A")最多255个字符，大约590行，但可以通过测试其长度（Len）来解决，如果超过限制，则使用字典创建Union范围：

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

 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
 Set rngUR = sh.UsedRange 'set the used range to avoid copying the whole row (only columns in used range)
 
 'build an array for the set interval:
 arr = Evaluate("TRANSPOSE(ROW(1:" & Int(lastR / (rW + 1)) & ")*" & rW + 1 & ")")
 If Len("A" & Join(arr, ",A")) <= 255 Then 'if concatenated array is less than 255 digits:
        Set rng = sh.Range("A" & Join(arr, ",A")).Offset(frstR)
 Else
        arr = Split("A" & Join(arr, ",A"), ",") 'create another array
        Dim i As Long, strArr As String, cellsNo As Long, dict As Object
        Set dict = CreateObject("Scripting.Dictionary")
        For i = 0 To UBound(arr)
               strArr = strArr & "," & arr(i) 'create a string by concatenation of the array elements (comma sep)
               If Len(strArr) >= 250 Then    'if the string length is near 255 (maximum for such a range)
                   If Not dict.Exists(1) Then
                       dict.Add 1, sh.Range(Mid(strArr, 2)).Offset(frstR) 'create first virtual string
                   Else
                      Set dict(1) = Union(dict(1), sh.Range(Mid(strArr, 2)).Offset(frstR)) ' create a Union range
                       cellsNo = sh.Range(Mid(strArr, 2)).cells.count    'determine the last number of array elements guiding to
                   End If                                                                               'a string of a length less than 255 characters
                   strArr = ""                                   'renitializate the string
               End If
               If UBound(arr) - i < cellsNo Then 'if reach the last array elements which still create a string of accepted length
                   Set dict(1) = Union(dict(1), sh.Range(Mid(strArr, 2)).Offset(frstR)) 'add the existing to the dictionary
                   strArr = ""                                  'renitializate the string
                   For k = i To UBound(arr)
                       strArr = strArr & "," & arr(k) 'create the string from the last array elements
                   Next k
                   'add it to the union range and exit the loop:
                   Set dict(1) = Union(dict(1), sh.Range(Mid(strArr, 2)).Offset(frstR)): Exit For
               End If
        Next i
        Set rng = dict(1)
 End If

 'copy the used range of row to be copied (2) in the discontinuous entire row range...
 Intersect(sh.rows(frstR), rngUR).Copy Intersect(rng, rngUR.EntireColumn)
 
 MsgBox "Ready..."
End Sub

上面的代码在不到一秒的时间内处理了5000行......它不再复制所有的行，而是只复制现有的列。