Excel 以VBA格式捕获工作表公式

我一直在寻找一种简单的方法来捕获VBA格式的工作表公式。我在下面提出了一个解决方案，我想与大家分享

如果运气好的话，这可能对以后的人有用：

Option Explicit

Public Const vbQuadrupleQuote As String = """""" 'represents 2 double quotes for use in VBA R1C1 formulas ("")
Public Const vbDoubleQuote As String = """" 'represents 1 double quote (")
Public Const vbSingleQuote As String = "'" 'represents 1 single quote (')

Sub CaptureFormulas()  'simplifies the capturing of worksheet formulas in VBA format

'Peter Domanico, May 2017

'Steps:

'(1) place this script in your personal macro workbook
'(2) open Immediate Window in VBA (Control + G)
'(3) select range to capture in Excel
'(4) run this script and follow prompts
'(5) a subscript or With statement containing formulas for your selection will be printed to the Immediate Window
'(6) use this subscript or With statement in your code

'set dims
Dim Rng             As Range
Dim CurrentColumn   As Variant
Dim CurrentRow      As Variant
Dim LastRow         As String
Dim RangeString     As String
Dim FormulaString   As String
Dim Ws              As String
Dim FinalString     As String
Dim FormulaType     As VbMsgBoxResult
Dim SubOrNot        As VbMsgBoxResult

'set worksheet string
Ws = Selection.Worksheet.Name

'fill formula dynamically to last row?
FormulaType = MsgBox(Prompt:="Fill formulas to last row?", _
            Buttons:=vbYesNoCancel, Title:="???")

'exit sub on user cancel
Select Case FormulaType
    Case vbCancel
        Exit Sub
End Select

'print complete subscript to Immediate Window?
SubOrNot = MsgBox(Prompt:="Print full subscript?", _
            Buttons:=vbYesNoCancel, Title:="???")

'exit sub on user cancel
Select Case SubOrNot
    Case vbCancel
        Exit Sub
End Select

'prints items neccesary for script
Select Case SubOrNot
    Case vbYes
        Debug.Print "Sub NewScript ()" & vbNewLine
End Select
Debug.Print vbTab & "Dim Ws as Worksheet"
Debug.Print vbTab & "Set Ws = Worksheets(" & vbDoubleQuote & Ws & vbDoubleQuote & ")"
Debug.Print vbTab & "LastRow = Ws.Cells(Rows.Count,1).End(xlUp).Row" & vbNewLine
Debug.Print vbTab & "With Ws"

'loop through each range in selection
For Each Rng In Selection
    CurrentColumn = Rng.Column
    CurrentRow = Rng.Row
    Select Case FormulaType
        Case vbYes
            LastRow = "LastRow"
        Case vbNo
            LastRow = CurrentRow
    End Select
    RangeString = vbTab & vbTab & ".Range(.Cells(" & CurrentRow & "," & CurrentColumn & "),.Cells(" & LastRow & "," & CurrentColumn & ")).FormulaR1C1="
    FormulaString = Rng.FormulaR1C1
    FormulaString = Replace(FormulaString, vbDoubleQuote, vbQuadrupleQuote)
    FinalString = RangeString & vbDoubleQuote & FormulaString & vbDoubleQuote
    Debug.Print FinalString
Next Rng

'prints closing items neccesary for script
Debug.Print vbTab & "End With" & vbNewLine
Select Case SubOrNot
    Case vbYes
        Debug.Print "End Sub"
End Select
Debug.Print vbNewLine

End Sub

---

如果你想对工作代码发表评论，或许还需要一些改进的想法，考虑把它发布在“谢谢”PeterT上，我会研究一下。that@PeterT在这里的代码审查上：如果你想对工作代码进行评论，也许还有一些改进的想法，考虑把它张贴在“谢谢”PeterT，我会研究。that@PeterT发布在代码审阅中，请点击此处：