Excel VBA：dynamic范围剪切和粘贴

这里的相关新手在VBA中，需要一些帮助修改代码以适应特定的用例。 除了修改代码之外，我还search了高低版本，但是迄今为止还没有成功find类似的用例//自己执行必要的更改。

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

我需要在Sheet1中的列“A”中search特定值的代码（例如，在附加图像中，报表标题为“Extra Header A”）。 然后从“Extra Header A”下的下一行复制到“Data 9”行下的空格和“Header B”到“Header E”的列到Sheet2（“A1”）。

用例图像：

下面列出的代码是我发现温和的成功（对不起，源不可用，因为我一起frankensteined这一点）。 目前这个代码的问题是它本质上只是静态的（通过修改if语句的范围方法），并没有考虑到每个dynamic报表中的行数。

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 

任何帮助提供将不胜感激！ 提前致谢。

编辑添加另一个图像的额外上下文。 红色将是我想要避免的数据，而蓝色是目标数据。 图片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来确保我正确地引用了我的variables，我已经把Application混乱的行到子的前端和结尾，我已经摆脱使用Copy而是直接引用值。

之前和之后：

如果你想保持TOTALS行，只需要摆脱js旁边的负数1。 我不确定你是否想要包括在A列中的空单元格。

Answer 2

另外（除了dwirony的正确观察），你的副本只会复制一行数据（c.row）将Range（“A”＆c.Row＆“：D”＆c.Row） “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 

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 

还应该快一点。 ;）