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

【问题标题】：Excel VBA: Dynamic range cut and pasteExcel VBA：动态范围剪切和粘贴
【发布时间】：2017-08-29 05:18:33
【问题描述】：

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

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

我需要在 Sheet1 中的“A”列中搜索特定值的代码（在附件中的示例中，报告标题将是“Extra Header A”）。然后（最好）从“Extra Header A”下的下一行复制到“Data 9”行下的空白处，并从“Header B”到“Header E”的列复制到Sheet2（“A1”）。

用例图片：

下面列出的代码是我发现的适度成功的代码（抱歉，源代码不可用，因为我已经把它放在一起弗兰肯斯坦了）。这段代码的当前问题是，它本质上似乎只是静态的（通过修改 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

我们将非常感谢提供任何帮助！提前致谢。

edit 添加了另一张图片作为附加上下文。红色是我希望避免的数据，而蓝色是目标数据。 Image 2

【问题讨论】：

For Each c In Range("A1:A500" & lastrow) 毫无意义。将其更改为 For Each c In Range("A1:A" & lastrow) 以使其动态。此外，您有一个 If 声明，没有 End If。另外，循环外的删除行有什么意义？？？
Dwirony，感谢您指出 End If 已解决。删除行删除了从我的原始代码提交中复制过来的“Extra Header A”行，因为它不需要。再次感谢您迄今为止的帮助。不幸的是，仍然需要了解如何在到达空白行后添加断点以进行复制。继续拉入工作表上所有剩余的行，即使它遇到空行（延续到工作表上的下一个报告）。
空白单元格在哪里，B-D 中的任何单元格？
哪个更容易完成，我将采取：可能是 Totals 行上“Header B”下的空白单元格，或者.. 可能是 Totals 行正下方的行。无论如何，在总计行之后的“空白行”之后会立即生成另一个报告（我需要避免）。我希望这是有道理的。
在下面查看我的答案。如果 B 列中的单元格为空白，它将跳过该行。

标签： vba excel

【解决方案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

编辑：好的，我已经重写了你的 sn-p 代码：

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，而是直接使用对值的引用。

之前和之后：

如果要保留TOTALS这一行，只需去掉js旁边的负1即可。由于 A 列中的单元格为空，我不确定您是否希望将其包含在内。

【讨论】：

【解决方案2】：

另外（除了 dwirony 的正确观察），您的副本只会复制一行数据（c.row）更改范围，Range("A" & c.Row & ":D" & c.Row) to Range("A" & c.Row & ":D" & 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

【讨论】：

谢谢你，正如这里提到的有点新手:)。我尝试了你对 mooseman 所做的编辑，是否可以在空白处添加一个停靠点？就目前而言，代码也提取了剩余的报告，需要针对特定的报告。想法？
嘿 Moose，我编辑添加了更多结构并更改了原始帖子的一些内容（添加了 End If 并将 ("A" & 1) 更改为 ("A1")）

【解决方案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

应该也快一点。 ;)

【讨论】：