复制单元格公式VBA

我在VBA中做了一个程序来复制特定列中每个单元格中的公式，我有30501个点，程序实际上很慢，即使计算100个点，还有更好的方法吗？复制单元格公式VBA

Sub Copyformulas() 


Dim i As Integer 
Dim cell As Range 
Dim referenceRange As Range 
Dim a As String 

a = "$T$30510" 
Set range1= ActiveSheet.Range("A1:A30510") 
Set myrange = Range("T16:T30510") 
i = 16 

Do Until Cells(20, 30510) 
    With range1 
     For Each cell In myrange 
      If cell.HasFormula Then 
       Cells(i, 35).Value = cell.Address 
       Cells(i, 36).Value = "'" & CStr(cell.Formula) 
       i = i + 1 
      End If 
     Next 
    End With 
Loop 
End Sub

来源

2016-06-28 Aus Mazin

尝试添加以下内容：

Application.Calculation = xlCalculationManual 
Application.ScreenUpdating = False 
Application.EnableEvents = False 

... Your Code ... 

Application.Calculation = xlCalculationAutomatic 
Application.ScreenUpdating = True 
Application.EnableEvents = True

您可能只需要第一个，但他们在使用所有好的做法。另外，您在哪里使用With ... End With声明？我没有看到它在块中的使用。

在模块的顶部使用Option Explicit是个好习惯。并且未声明range1和myrange。

Application.Calculation

当工作表被访问或范围的先例已被更改时，Excel将自动重新计算工作表上的公式。由于循环超过30,000次，这会导致Excel在循环中重新计算每次，从而降低性能。

Application.ScreenUpdating

此行停止屏幕闪烁和其他事情发生的宏运行Excel中。

Application.EnableEvents

这行关闭的事件，如Worksheet_Change，所以该事件不会被触发。如果未关闭，则工作表上发生更改时，更改事件中的代码将运行。如果你有一个Worksheet_SelectionChange事件，那么代码将在你每次选择一个不同的单元时运行。这些事件写入VBE项目窗口中的工作表或工作簿对象中，并且有许多事件可供选择。这是一个非常简单的例子。将在项目窗口中Sheet1对象如下：

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
    MsgBox "Hi!" 
End Sub

现在点击周围的工作表上。您会看到它对每个选择更改作出响应。现在将以下内容放置在常规模块中：

Sub TestEnableEvents() 

Application.EnableEvents = False 
ActiveCell.Offset(1, 0).Select 
Application.EnableEvents = True 

End Sub

当您运行上述代码时，消息框不会被触发。

来源

2016-06-28 10:57:21 Brian

感谢这个，还真管用，你可以给我解释一下这背后的根本？我在VBA编程上有一个非常基本的知识。 –

@AusMazin很高兴工作！请参阅上面的编辑以获得简要说明。 – Brian

您可以使用SpecialCells来优化您的范围。你不需要使用它暗示的ActiveSheet。

设置RSOURCE =范围（ “A16：A30510”）SpecialCells（xlCellTypeFormulas）

Sub Copyformulas() 
    Application.Calculation = xlManual 
    Application.ScreenUpdating = False 
    Application.EnableEvents = False 

    Dim c As Range 
    Dim rSource As Range 

    Set rSource = ActiveSheet.Range("A16:A30510").SpecialCells(xlCellTypeFormulas) 

    For Each c In rSource 
     c.Offset(0, 34) = c.Address 
     c.Offset(0, 35) = "'" & c.Formula 
    Next 

    Application.Calculation = xlAutomatic 
    Application.ScreenUpdating = True 
    Application.EnableEvents = True 
End Sub

来源

2016-06-28 11:14:58

复制单元格公式VBA

回答

相关问题