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
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
2条答案
按热度按时间mzillmmw1#
这里有一个为您准备的启动程序:
在一个新的工作表上运行这个程序,并添加一些条件格式来产生你需要的颜色。
eufgjt7s2#
请尝试下一个代码。我使用了一个动态创建的数组构建了一个虚拟范围:
上面的解决方案有点花哨......它限制不连续范围地址
("A" & Join(arr, ",A")
最多255个字符,大约590行,但可以通过测试其长度(Len
)来解决,如果超过限制,则使用字典创建Union
范围:上面的代码在不到一秒的时间内处理了5000行......它不再复制所有的行,而是只复制现有的列。