|
楼主 |
发表于 2016-6-26 20:49
|
显示全部楼层
Sub 读取公式并存入文本文件()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim FormulaCells As Range, Cell As Range
Dim FormulaSheet As Worksheet
Dim Row As Integer, myfile$, objFolder
Dim fso As Scripting.FileSystemObject
Dim mt As Scripting.TextStream
'创建Range对象
On Error Resume Next
Set objShell = CreateObject("Shell.Application")
Set FormulaCells = Range("A1").SpecialCells(xlFormulas, 23)
'没有找到公式
If FormulaCells Is Nothing Then
MsgBox "当前工作表中没有公式!"
Exit Sub
End If
mypath = "E:\Excel\Excel精英群\写入删除代码\写入代码多层子文件夹\文本文件公式\"
myfile = mypath & "\" & Replace(ActiveWorkbook.Name, ".xlsm", "") & Replace(Replace(ActiveWorkbook.Path, "\", " "), ":", " ") & ".txt"
Set fso = New Scripting.FileSystemObject
Set mt = fso.CreateTextFile(Filename:=myfile, overwrite:=True)
'读取公式,同时在状态栏中显示进度。
For Each Cell In FormulaCells
mt.Write Cell.Address(RowAbsolute:=False, ColumnAbsolute:=False) & vbCrLf
mt.Write Cell.Formula & vbCrLf
Next
mt.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
' MsgBox "公式保存成功!"
End Sub
|
|