按一定间隔插入行；复制和/或合计间隔以上的数据
按一定间隔插入行；复制和/或合计间隔以上的数据
提问于 2020-06-14 22:02:13
我的问题与测试数据有关，我想每三行“汇总”一次(请参见下图)。
我想在每三行之后插入一个空行，并根据我添加的图像填充它:从上面的行复制信息或将上面三行的数据相加。
理想情况下，在最后:所有新插入的行都应该复制到新的工作表中。
我已经设法每三行插入一行，但接下来的步骤超出了我在Excel VBA中的编程技能...
Sub InsertRowsAtIntervals()
Dim Rng As Range
Dim xInterval As Integer
Dim xRows As Integer
Dim xRowsCount As Integer
Dim xNum1 As Integer
Dim xNum2 As Integer
Dim WorkRng As Range
Dim xWs As Worksheet
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
xRowsCount = WorkRng.Rows.Count
xInterval = 2
xRows = 1
xNum1 = WorkRng.Row + xInterval
xNum2 = xRows + xInterval
Set xWs = WorkRng.Parent
For i = 1 To Int(xRowsCount / xInterval)
xWs.Range(xWs.Cells(xNum1, WorkRng.Column), xWs.Cells(xNum1 + xRows - 1, WorkRng.Column)).Select
Application.Selection.EntireRow.Insert
xNum1 = xNum1 + xNum2
Next
End Sub
回答 2
Stack Overflow用户
发布于 2020-06-14 22:22:57
如果您的目标是每三行对数据求和或提取数据，那么可以在不使用VBA的情况下使用不破坏源数据的公式来实现。
如果源数据从第1行开始，则可以使用此公式，从第2行开始，然后向下复制：
要对3行一组的值求和，请执行以下操作：
=SUM(INDEX(A:A,((ROW()-1)*3)-2):INDEX(A:A,((ROW()-1)*3)))获取每三个值一次
=INDEX(B:B,((ROW()-1)*3))同样，公式从第2行开始，否则结果将不同。
Stack Overflow用户
发布于 2020-06-15 01:36:45
插入小计
- 调整常量ants，包括工作簿。在代码底部附近，还有两个constants.
Target仅包含小计行的值，而Result包含包括小计行在内的完整(结果)范围的值。- 在测试时，
Result将写入第三个worksheet. - After测试，如果您仍然希望覆盖原始数据，请在constants.
Target输出中注释或删除从Either到Or的行，并取消注释最后一行。
代码
Option Explicit
Sub insertSubTotals()
' Source
Const srcName As String = "Sheet1"
Const FirstRow As Long = 1
Const RowInterval As Long = 3
Const FirstSumColumn As Long = 3
Const ColInterval As Long = 2
Const Cols As String = "A:Q"
' Target
Const tgtName As String = "Sheet2"
Const tgtFirstCell As String = "A1"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
Dim src As Worksheet: Set src = wb.Worksheets(srcName)
' Write values from Source Range to Source Array.
Dim rng As Range
Set rng = getColumnRange(src, src.Columns(Cols).Column, FirstRow)
If rng Is Nothing Then Exit Sub
Dim Source As Variant
Source = rng.Resize(, src.Columns(Cols).Columns.Count)
Set rng = Nothing
' Write values from Source Array to Target and Result Arrays.
Dim UB1 As Long: UB1 = UBound(Source)
Dim UB2 As Long: UB2 = UBound(Source, 2)
Dim Target As Variant: ReDim Target(1 To Int(UB1 / RowInterval), 1 To UB2)
Dim Result As Variant: ReDim Result(1 To UB1 + UBound(Target), 1 To UB2)
Dim i As Long, j As Long, k As Long, m As Long, o As Long, q As Long
Dim CurrVal As Double
For i = 1 To UB1
k = k + 1
For j = 1 To UB2
Result(k, j) = Source(i, j)
Next j
If i Mod RowInterval = 0 Then
k = k + 1: m = i - RowInterval + 1: q = q + 1: CurrVal = 0
For j = 1 To UB2
If j >= FirstSumColumn And j Mod ColInterval _
= FirstSumColumn Mod ColInterval Then
For o = m To m + RowInterval - 1
CurrVal = CurrVal + Source(o, j)
Next o
Else
CurrVal = Source(i, j)
End If
Result(k, j) = CurrVal
Target(q, j) = CurrVal
Next j
End If
Next i
' Write values from Target Array to Target Range.
wb.Worksheets(tgtName).Range(tgtFirstCell).Resize(q, UB2) = Target
' Either:
' While testing, write values from Result Array to Result Range.
Const resName As String = "Sheet3"
Const resFirstCell As String = "A1"
wb.Worksheets(resName).Range(resFirstCell).Resize(k, UB2) = Result
' Or:
' Write values from Result Array to Result Range (overwrite).
'wb.Worksheets(srcName).Columns(colls).Cells(1).Resize(k, UB2) = Result
End Sub
Function getColumnRange(Sheet As Worksheet, _
ByVal AnyColumn As Variant, _
ByVal FirstRow As Long) As Range
Dim rng As Range
Set rng = Sheet.Columns(AnyColumn).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Function
If rng.Row < FirstRow Then Exit Function
Set getColumnRange = Sheet.Range(Sheet.Cells(FirstRow, AnyColumn), rng)
End Function页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/62378751
复制相关文章
相似问题
腾讯云开发者
