循环遍历一个范围。 如果等于值，则复制。 运行但没有结果

我已经尝试使用胶印来复制和粘贴大约一百万个其他的东西。 这曾经有大约十个ElseIf，我注意到试图简化，以帮助我弄清楚。 我唯一能想到的另一件事是，我有这个脑筋抽筋，所以任何帮助将不胜感激！

Sub areax() Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range Dim Lr As Long For Lr = Cells(Cells.Rows.Count, "B").End(xlUp).Row To 6 Step -1 If Cells(Lr, "B") <> 0 Then If Cells(Lr, "B") = 6 Then Set Rng1 = Range("E" & ActiveCell.Row & ":I" & ActiveCell.Row) Set Rng2 = Range("E" & Rows.Count).End(xlUp).Offset(1) Rng1.COPY Rng2 Application.CutCopyMode = False Else If Cells(Lr, "B") = 12 Then Set Rng1 = Range("E" & ActiveCell.Row & ":J" & ActiveCell.Row) Set Rng2 = Range("K" & ActiveCell.Row & ":P" & ActiveCell.Row) Set Rng4 = Range("E" & Rows.Count).End(xlUp).Offset(1) Rng1.COPY Rng4 Rng2.COPY Rng4 Application.CutCopyMode = False End If End If End If Next Lr End Sub 

Answer 1

OK山姆斧 – 今天晚上必须注销，但请尝试下面的代码。

从我上一个查询注释到你，它假设列B与原始数据网格（9）具有相同的行数，并且我们只在重build网格中使用列E：J和K：P。 如果情况不是这样，那么你可以做一些合适的MODS。

此外，还适用以下假设，再次修改以适应您的上下文：

假设网格数据与col B在同一张纸上

假设这张表被称为“数据”

假定重build的网格数据从原始数据网格起始列开始

我已经使用了几个variables，以便您可以灵活地轻松更改您的输出/布局等。我也在代码中做了两个“replace”。 1.用SELECT CASE构造replaceIF THEN构造，该构造将允许您添加其他条件，并且2.将col B值大于0的testingreplace为testing数值。 它不应该然后崩溃，如果一个string意外地进入。

@Steffen Sylvest Neilson已经慷慨地承认了这个暗淡的评论，并有助于提供了一个链接，供你探索。

由于我缺乏理解，可能对您的需求还不完美，但正如前面所述，这对您来说应该是一个很好的开端。

PS解释为什么你似乎没有复制任何东西可能是ActiveCell可能会被选中您的数据之外。 ActiveCell不遵循你的循环计数器。

 Sub areax() Dim Rng1 As Range, Rng2 As Range Dim lBrow As Long, lGridRow As Long, c As Long Dim sdRow As Long, sdCol As Long Dim gridsRow As Long, gridsCol As Long 'data start r/c sdRow = 6 sdCol = 2 'grid start r/c gridsRow = 6 gridsCol = 5 With Sheets("Data") lBrow = .Cells(Rows.Count, sdCol).End(xlUp).Row 'for each row in col B For c = sdRow To lBrow If IsNumeric(.Cells(c, "B")) Then 'set next available row at bottom of grid lGridRow = .Cells(Rows.Count, gridsCol).End(xlUp).Row + 1 'test col B cell value Select Case .Cells(c, sdCol) Case Is = 6 Set Rng1 = .Range(.Cells(c, "E"), .Cells(c, "J")) Rng1.Copy Destination:=.Cells(lGridRow, gridsCol) Application.CutCopyMode = False Case Is = 12 Set Rng1 = .Range(.Cells(c, "E"), .Cells(c, "J")) Set Rng2 = .Range(.Cells(c, "K"), .Cells(c, "P")) Rng1.Copy Destination:=.Cells(lGridRow, gridsCol) 'add 1 to last grid row because of double-copy lGridRow = lGridRow + 1 Rng2.Copy Destination:=.Cells(lGridRow, gridsCol) End Select End If Next c Application.CutCopyMode = False End With End Sub