复制单元格公式VBA

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

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 

Answer 1

尝试添加以下内容：

 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和macros运行时发生的其他事情。

 Application.EnableEvents 

此行closures事件，如Worksheet_Change ，以便事件不被触发。 如果没有closures，那么在工作表上发生更改时，更改事件中的代码将运行。 如果您有一个Worksheet_SelectionChange事件，则代码将在您每次select不同的单元格时运行。 这些事件写在VBE项目窗口中的工作表或工作簿对象中，并且有许多事件可供select。 这是一个非常简单的例子。 在项目窗口的Sheet1对象中放置以下内容：

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

现在点击工作表上。 你会看到它响应每个select的变化。 现在将以下内容放在常规模块中：

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

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

Answer 2

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

设置rSource = Range（“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