Vba 优化通过数组的行和列的循环

我有一个大约400列30行的数组 我想检查每一列中的所有列和每一行，并测试每个单元格中的某个单元格..比如如果它包含负数，如果它包含负数，我想将单元格本身和它上面的某些单元格复制到另一张纸上

我使用了2个标准的“

for loop

”，但是这需要很多时间，每个单元有10多个不同的测试

我想知道是否有人知道一种更有效的方法，比如使用“for each”语句……我一直在尝试这种方法，但运气不好-

 Set FinalSht = ActiveWorkbook.Worksheets("Final")
    Cnter = FinalSht.Cells(5, FinalSht.Columns.Count).End(xlToRight).Column
    Rowter = FinalSht.Cells(FinalSht.Rows.Count, "B").End(xlUp).Row

    Set AnRe = ActiveWorkbook.Worksheets("Anomaly")
    AnRe.Cells.ClearContents

    Set SRng = FinalSht.Range(FinalSht.Cells(5, 3), FinalSht.Cells(14, Cnter))

    RowCount = 0
    ColCount = 0

    For Each RowRng In SRng.Rows
    RowCount = RowCount + 1

             For Each ColRng In SRng.Columns
             ColCount = ColCount + 1
             Select Case True
                Case FinalSht.Cells(RowRng.Rows, ColRng.Columns) < 0
                With AnRe
                     .Cells(RowCount, ColCount).Value = FinalSht.Cells(RowRng.Rows, ColRng.Columns).Value
                End With

                  End Select

                Next ColRng


 Next RowRng

Set FinalSht=ActiveWorkbook.Worksheets（“最终版”）
Cnter=FinalSht.Cells（5，FinalSht.Columns.Count）.End（xlToRight.Column）
Rowter=FinalSht.Cells（FinalSht.Rows.Count，“B”）.End（xlUp.Row）
设置AnRe=ActiveWorkbook.Worksheets（“异常”）
AnRe.Cells.ClearContents
设置SRng=FinalSht.Range（FinalSht.Cells（5,3），FinalSht.Cells（14,Cnter））
行计数=0
ColCount=0
对于SRng.行中的每个行
RowCount=RowCount+1
对于SRng.列中的每个列
ColCount=ColCount+1
选择Case True
Case FinalSht.Cells（RowRng.Rows，ColRng.Columns）<0
与安雷
.Cells（RowCount，ColCount）.Value=FinalSht.Cells（RowRng.Rows，ColRng.Columns）.Value
以
结束选择
下一节课
下一轮

---

感谢您提供的任何帮助…

检查代码是否慢的一些常规方法：

声明变量以适合数据，请参阅

去掉未使用的变量、代码部分

查看有关如何为每个循环使用

的一些想法（在一个范围内遍历所有单元格时，每个循环不需要两个）<对于每个

循环，code>通常比

循环快

你真的需要优化你的循环：确保你只循环你真正需要的

此外，优化循环中的任何内容。确保您只做了循环内部需要做的事情，因为这才是最重要的


关于您的代码：
基本上你的代码很慢是因为两件事

Cnter = FinalSht.Cells(5, FinalSht.Columns.Count).End(xlToRight).Column

那
xlToRight
使它在16000多个列中循环，而不是仅在400个列中循环。差别很大。我告诉你剩下的只是速度增加的1%。调试代码时，请使用F8单步执行，并使用watches或locals窗口

另一个问题是每个

循环有两个

，而不仅仅是您实际需要的一个


下面的代码运行不到一秒钟。希望这有帮助

Sub test()

Dim Finalsht As Worksheet
Dim AnEr As Worksheet
Dim Cnter As Integer
Dim Rownter As Long
Dim SRng As Range
Dim myCell As Range

  Set Finalsht = ActiveWorkbook.Worksheets("Final")
  Cnter = Finalsht.Cells(5, Finalsht.Columns.Count).End(xlToLeft).Column
  Rowter = Finalsht.Cells(Finalsht.Rows.Count, 2).End(xlUp).Row

  Set AnRe = ActiveWorkbook.Worksheets("Anomaly")
  AnRe.Cells.ClearContents

  Set SRng = Finalsht.Range(Finalsht.Cells(5, 3), Finalsht.Cells(14, Cnter))

  For Each myCell In SRng
    Select Case True
      Case myCell.Value < 0
        With AnRe
             .Cells(myCell.Row, myCell.Column).Value = myCell.Value
        End With

      End Select

  Next myCell

End Sub

子测试（）
将最终结果设置为工作表
Dimaner作为工作表
作为整数的Dim Cnter
暗色长
变光SRng As范围
暗淡的迈塞尔山脉
Set Finalsht=ActiveWorkbook.Worksheets（“最终版”）
Cnter=Finalsht.Cells（5，Finalsht.Columns.Count）.End（xlToLeft.Column）
Rowter=Finalsht.Cells（Finalsht.Rows.Count，2）.End（xlUp）.Row
设置AnRe=ActiveWorkbook.Worksheets（“异常”）
AnRe.Cells.ClearContents
设置SRng=Finalsht.Range（Finalsht.Cells（5,3），Finalsht.Cells（14,Cnter））
对于SRng中的每个迈塞尔
选择Case True
案例迈塞尔值<0
与安雷
.Cells（myCell.Row，myCell.Column）.Value=myCell.Value
以
结束选择
下一个迈塞尔
端接头
您的Cnetr变量似乎是错误的，它是否应该转到
xlToLeft
？现在您正在检查16000多个列。那会加快速度的。不管怎样，我会马上给你一个密码。非常感谢！这是可行的，但是我想复制特定的单元格…例如：如果mycell.value<0，那么我想复制该行上方3行的单元格。那么，请尝试
mycell.row-3
，或者类似的操作。此代码中的myCell是一个有效的单元格引用，如Activecell或range（“a1”），您只需获取其行号，然后使用它。例如：
.Cells（myCell.row，myCell.Column）。Value=Cells（myCell.row-3，myCell.Column）。Value
或
.Cells（myCell.row，myCell.Column）。Value=myCell.Offset（-3,0）.Value
很抱歉…无法使其工作。也许我解释得不对。如果mycell.value<0，则我希望将原始工作表中此单元格的3行向上复制到同一位置，即新工作表中包含负值的单元格上方的3行。就像用负值复制单元格上方的标题一样，非常感谢。我用它玩了，代码也起了作用…欣赏它