[已解决]合并代码（2）遍历工作表

乐乐2006201506 · 发表于 2016-6-14 22:31

本帖最后由乐乐2006201506 于 2016-6-15 12:56 编辑

遍历一个工作簿中所有有公式工作表中的公式，然后存入文本文件，并且可以实现还原。该怎么修改或者重写代码？当然要在实现下面代码效果的基础上遍历哦！

Sub 读取公式并存入文本文件()
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
Set objFolder = objShell.BrowseForFolder(0, "请选择文件存放位置", 0, 0)
If Not objFolder Is Nothing Then
mypath = objFolder.self.Path
Else
mypath = ""
Exit Sub
End If
myfile = mypath & "\" & Replace(ThisWorkbook.Name, ".xlsm", "") & Replace(Replace(ThisWorkbook.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
MsgBox "公式保存成功！"
End Sub

Sub 读取文本文件并放入指定工作表()
Dim fso As Scripting.filesystemobject
Dim mt As Scripting.textstream
Dim myfile$, i&, sht$, b As Boolean, rng$, fm$
myfile = Application.GetOpenFilename("TXT Files (*.txt), *.txt", 0, "选定文件", , False)
If myfile = "" Then Exit Sub
Set fso = New Scripting.filesystemobject
Set mt = fso.OpenTextFile(Filename:=myfile, IOMode:=ForReading)
sht = "测试" '公式插入那个工作表
With mt
Do Until .AtEndOfStream
i = i + 1
If i Mod 2 = 1 Then
b = False
rng = .ReadLine
Else
b = True
fm = .ReadLine
End If
If b = True Then Sheets(sht).Range(rng).Formula = fm
Loop
.Close
End With
MsgBox "公式还原成功！"
End Sub

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-6-15 09:07

代码如下，但是这里要注意还原是按照工作表的名称进行还原的，即导出之前是按照每个工作表的名称进行存储的，读取还原的时候也是按照工作表名称进行：

Sub 读取公式并存入文本文件()
Dim FormulaCells As Range, Cell As Range
Dim sht As Worksheet
Dim Row As Integer, myfile$, objFolder As Object
Dim fso As Scripting.filesystemobject
Dim mt As Scripting.textstream
'创建Range对象
On Error Resume Next
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "请选择文件存放位置", 0, 0)
If Not objFolder Is Nothing Then
mypath = objFolder.self.Path
Else
mypath = ""
Exit Sub
End If
myfile = mypath & "" & Replace(ThisWorkbook.Name, ".xlsm", "") & Replace(Replace(ThisWorkbook.Path, "", " "), ":", " ") & ".txt"
Set fso = New Scripting.filesystemobject
Set mt = fso.CreateTextFile(Filename:=myfile, overwrite:=True)
'读取公式，同时在状态栏中显示进度。
Set objShell = CreateObject("Shell.Application")
For Each sht In ThisWorkbook.Sheets
Set FormulaCells = sht.Range("A1").SpecialCells(xlFormulas, 23)
If FormulaCells <> Null Then
For Each Cell In FormulaCells
mt.Write sht.Name & vbCrLf
mt.Write Cell.Address(RowAbsolute:=False, ColumnAbsolute:=False) & vbCrLf
mt.Write Cell.Formula & vbCrLf
Next
End If
Next
mt.Close
MsgBox "公式保存成功！"
End Sub
Sub 读取文本文件并放入指定工作表()
Dim fso As Scripting.filesystemobject
Dim mt As Scripting.textstream
Dim myfile$, i&, sht$, b As Boolean, rng$, fm$
myfile = Application.GetOpenFilename("TXT Files (*.txt), *.txt", 0, "选定文件", , False)
If myfile = "" Then Exit Sub
Set fso = New Scripting.filesystemobject
Set mt = fso.OpenTextFile(Filename:=myfile, IOMode:=ForReading)
sht = "测试" '公式插入那个工作表
With mt
Do Until .AtEndOfStream
i = i + 1
If i Mod 3 = 1 Then
b = False
sht = .ReadLine
End If
If i Mod 3 = 2 Then
b = False
rng = .ReadLine
End If
If i Mod 3 = 0 Then
b = True
fm = .ReadLine
End If
If b = True Then Sheets(sht).Range(rng).Formula = fm
Loop
.Close
End With
MsgBox "公式还原成功！"
End Sub

复制代码

跳转到最佳答案楼层

老司机带带我 · 发表于 2016-6-15 09:07

代码如下，但是这里要注意还原是按照工作表的名称进行还原的，即导出之前是按照每个工作表的名称进行存储的，读取还原的时候也是按照工作表名称进行：

Sub 读取公式并存入文本文件()
Dim FormulaCells As Range, Cell As Range
Dim sht As Worksheet
Dim Row As Integer, myfile$, objFolder As Object
Dim fso As Scripting.filesystemobject
Dim mt As Scripting.textstream
'创建Range对象
On Error Resume Next
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "请选择文件存放位置", 0, 0)
If Not objFolder Is Nothing Then
mypath = objFolder.self.Path
Else
mypath = ""
Exit Sub
End If
myfile = mypath & "" & Replace(ThisWorkbook.Name, ".xlsm", "") & Replace(Replace(ThisWorkbook.Path, "", " "), ":", " ") & ".txt"
Set fso = New Scripting.filesystemobject
Set mt = fso.CreateTextFile(Filename:=myfile, overwrite:=True)
'读取公式，同时在状态栏中显示进度。
Set objShell = CreateObject("Shell.Application")
For Each sht In ThisWorkbook.Sheets
Set FormulaCells = sht.Range("A1").SpecialCells(xlFormulas, 23)
If FormulaCells <> Null Then
For Each Cell In FormulaCells
mt.Write sht.Name & vbCrLf
mt.Write Cell.Address(RowAbsolute:=False, ColumnAbsolute:=False) & vbCrLf
mt.Write Cell.Formula & vbCrLf
Next
End If
Next
mt.Close
MsgBox "公式保存成功！"
End Sub
Sub 读取文本文件并放入指定工作表()
Dim fso As Scripting.filesystemobject
Dim mt As Scripting.textstream
Dim myfile$, i&, sht$, b As Boolean, rng$, fm$
myfile = Application.GetOpenFilename("TXT Files (*.txt), *.txt", 0, "选定文件", , False)
If myfile = "" Then Exit Sub
Set fso = New Scripting.filesystemobject
Set mt = fso.OpenTextFile(Filename:=myfile, IOMode:=ForReading)
sht = "测试" '公式插入那个工作表
With mt
Do Until .AtEndOfStream
i = i + 1
If i Mod 3 = 1 Then
b = False
sht = .ReadLine
End If
If i Mod 3 = 2 Then
b = False
rng = .ReadLine
End If
If i Mod 3 = 0 Then
b = True
fm = .ReadLine
End If
If b = True Then Sheets(sht).Range(rng).Formula = fm
Loop
.Close
End With
MsgBox "公式还原成功！"
End Sub

复制代码

		自动登录	找回密码
密码			注册