以VBA格式捕获工作表公式

Question

我一直在寻找一种以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