根据条件复制Sheet1中的多个Range，并将其粘贴到Sheet2的Alongside中

我有一个问题，我在Excel中的VBA代码。 我试图让excel自动从sheet1的基础上将多个范围（B，C，D，F，G）的内容复制到sheet2并排。 例如，这将如何看起来像：

这是我的代码，只复制范围B到D：

Sub CopyButton() Dim cell As Range Dim lastRow As Long, i As Long lastRow = Range("D" & Rows.Count).End(xlUp).Row i = 5 For Each cell In Sheets(1).Range("D2:D" & lastRow) If cell.Value > 0 Then r=cell.row range("B" & r & ":D" & r).Copy Sheets(2).Cells(i, 1) i = i + 1 End If Next End Sub 

任何帮助，将不胜感激。

Answer 1

使用AutoFilter方法可以轻松地完成此操作，以使用xlCellTypeVisible xlCellType枚举选项来隔离行和Range.SpecialCells的Union方法 。

 Sub xferBCDFG() With Worksheets("sheet1") If .AutoFilterMode Then .AutoFilterMode = False With .Cells(1, 1).CurrentRegion .AutoFilter field:=4, Criteria1:="<>0" With Union(.Range("B:D"), .Range("F:G")).SpecialCells(xlCellTypeVisible) .Copy Destination:=Worksheets("Sheet2").Cells(4, 1) End With End With If .AutoFilterMode Then .AutoFilterMode = False End With End Sub 

^{Sheet1上的示例数据}

^{在Sheet2上的结果}