[已解决]合并代码

老司机带带我

乐乐2006201506 发表于 2016-6-13 21:09
也可以吧，主要是能实现我想提取的工作表中的公式能够存储到另外一个地方，并将文件命名为和工作表所在工作 ...

明天了，今天死了太多脑细胞了兄弟！

乐乐2006201506

好的，太感谢您了！

老司机带带我

读取至文本文件，然后从文本文件将公式还原到指定工作表中，最新代码如下：
由于是用FSO来操作，所以工作簿请需引用对应DLL，如下图：

1. Sub 读取公式并存入文本文件()
   
2.     Dim FormulaCells As Range, Cell As Range
   
3.     Dim FormulaSheet As Worksheet
   
4.     Dim Row As Integer, myfile$, objFolder
   
5.     Dim fso As Scripting.filesystemobject
   
6.     Dim mt As Scripting.textstream
   
7.     '创建Range对象
   
8.     On Error Resume Next
   
9.     Set objShell = CreateObject("Shell.Application")
   
10.     Set FormulaCells = Range("A1").SpecialCells(xlFormulas, 23)
    
11.     '没有找到公式
    
12.     If FormulaCells Is Nothing Then
    
13.         MsgBox "当前工作表中没有公式！"
    
14.         Exit Sub
    
15.     End If
    
16.     Set objFolder = objShell.BrowseForFolder(0, "请选择文件存放位置", 0, 0)
    
17.     If Not objFolder Is Nothing Then
    
18.         mypath = objFolder.self.Path
    
19.     Else
    
20.         mypath = ""
    
21.         Exit Sub
    
22.     End If
    
23.     myfile = mypath & "" & Replace(ThisWorkbook.Name, ".xlsm", "") & ".txt"
    
24.     Set fso = New Scripting.filesystemobject
    
25.     Set mt = fso.createtextfile(Filename:=myfile, overwrite:=True)
    
26.     '读取公式，同时在状态栏中显示进度。
    
27.     For Each Cell In FormulaCells
    
28.         mt.write Cell.Address(RowAbsolute:=False, ColumnAbsolute:=False) & vbCrLf
    
29.         mt.write Cell.Formula & vbCrLf
    
30.     Next
    
31.     mt.Close
    
32.     MsgBox "公式保存成功！"
    
33. End Sub
    
34. Sub 读取文本文件并放入指定工作表()
    
35.     Dim fso As Scripting.filesystemobject
    
36.     Dim mt As Scripting.textstream
    
37.     Dim myfile$, i&, sht$, b As Boolean, rng$, fm$
    
38.     myfile = Application.GetOpenFilename("TXT Files (*.txt), *.txt", 0, "选定文件", , False)
    
39.     If myfile = "" Then Exit Sub
    
40.     Set fso = New Scripting.filesystemobject
    
41.     Set mt = fso.OpenTextFile(Filename:=myfile, IOMode:=ForReading)
    
42.     sht = "测试"  '公式插入那个工作表
    
43.     With mt
    
44.         Do Until .AtEndOfStream
    
45.             i = i + 1
    
46.             If i Mod 2 = 1 Then
    
47.                 b = False
    
48.                 rng = .ReadLine
    
49.             Else
    
50.                 b = True
    
51.                 fm = .ReadLine
    
52.             End If
    
53.             If b = True Then Sheets(sht).Range(rng).Formula = fm
    
54.         Loop
    
55.         .Close
    
56.     End With
    
57.     MsgBox "公式还原成功！"
    
58. End Sub

复制代码

sweetyan

学习一下。谢谢

sweetyan

初学者，也学习一下，谢谢。