Excel VBA：动态范围剪切和粘贴

Question

VBA中的相对新手，需要一些帮助来修改代码以适应特定的用例。除了修补代码之外，我还搜索了高低，但迄今为止找不到类似的用例//我自己执行必要的更改是不成功的。

使用案例：在一个工作表中生成一个导出的报表，该报表在包含总计的行之后用一个空格分隔。每个报告的名称都是静态的，但每个报告中包含的数据量是动态的（它可以包含多少行）。

我需要在Sheet1中搜索列“A”以获取特定值的代码（附加图像中的示例是报告标题的“Extra Header A”）。然后（优选地）从“Extra Header A”下的下一行向下复制到具有“Data 9”的行下面的空白空间，并从具有“Header B”到“Header E”的列复制到Sheet2（“A1”）。

用例图片：

下面列出的代码就是我已经取得了一定的成功（抱歉来源不可用，因为我已将Frankensteined合在了一起）。此代码的当前问题是它本质上只是静态的（通过修改if语句范围方法）并且不考虑每个报告中的动态行数。

Sub Cells_Loop()

Dim c As Range, lastrow As Long


lastrow = Cells(Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False

For Each c In Range("A1:A500" & lastrow)
    If c.Value = "Extra Header A" Then Range("A" & c.Row & ":D" & c.Row).Copy Worksheets("Sheet2").Range("A" & 1)
Next c

Worksheets("Sheet2").Rows(1).Delete Shift:=xlUp

Application.ScreenUpdating = True

End Sub

提供的任何帮助都会非常赞赏！提前谢谢。

编辑为其他上下文添加了另一张图片。 Red是我希望避免的数据，而blue是目标数据。 Image 2

Answer 1

不要复制空行（假设空白在B列中）

For Each c In Range("A1:A" & lastrow)
    'Makes sure it's not blank
    If Range("B" & c.Row).Value <> "" Then
        If c.Value = "Extra Header A" Then 
            Range("A" & c.Row & ":D" & c.Row).Copy Worksheets("Sheet2").Range("A" & 1)
        End If
    End If
Next c

编辑：好的，我已经重写了你的代码片段：

Option Explicit
Sub Test()
Application.ScreenUpdating = False

Dim i As Integer, j As Integer, lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row

For i = 1 To lastrow
    If Range("A" & i).Value = "Extra Header A" Then
        For j = i To lastrow
            If Range("A" & j).Value = "" Then
                Worksheets("Sheet2").Range("A1:D" & j - 1 - i).Value = Worksheets("Sheet1").Range("A" & i & ":D" & j - 1).Value
            End If
        Next j
    End If
Next i

'Don't need shift up
Worksheets("Sheet2").Rows(1).Delete

Application.ScreenUpdating = True
End Sub

请注意我如何添加格式，使用Option Explicit确保我正确引用我的变量，我已经移动了混乱的行Application到子的前端和后端，我已经摆脱了使用Copy而只是使用对值的直接引用。

之前＆amp;后：

如果你想保留TOTALS行，只需摆脱js旁边的减号1。由于A栏中的空单元格，我不确定是否要包含它。

Answer 2

另外（除了dwirony的正确观察），你的副本只会复制一行数据（c.row）更改范围，范围（“A”＆amp; c.Row＆amp;“：D”＆amp; c .Row）到Range（“A”＆amp; c.Row＆amp;“：D”＆amp; lastrow）

Cells_Loop()
Dim c As Range, lastrow As Long
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
'c.row
For Each c In Range("A1:A" & lastrow)
    If c.Value = "Extra header" Then 
        Range("A" & c.Row & ":D" & lastrow).Copy Worksheets("Sheet2").Range("A1")
    End If
Next c
Worksheets("Sheet2").Rows(1).Delete Shift:=xlUp
Application.ScreenUpdating = True
End Sub

Answer 3

您可以使用这样的内置工具，而不是单独检查所有单元格：

Sub test()
  With Worksheets("Sheet1")
    Dim x As Range
    Set x = .Columns(1).Find("Extra Header A", , xlValues, 1, , , 1).Offset(1)
    .Range(x, x.End(xlDown).Offset(1, 3)).Copy Worksheets("Sheet2").Cells(1)
  End With
End Sub

还应该快一点。 ;）