[已解决]合并代码

乐乐2006201506 · 发表于 2016-6-13 20:10

本帖最后由乐乐2006201506 于 2016-6-14 12:07 编辑

1.怎样将下面代码（提取带公式的单元格）提出来的公式写入代码（而不是放入新的工作表单元格中，即不用创建新工作表，而是提取后存入代码中）；
2.然后通过提取出来的含公式代码实现还原（而不是现在的先创建一个新工作表，将提取的公式赋值到特定单元格，然后间接实现公式还原）。
谢谢！

Sub 提取带公式的单元格()
Dim FormulaCells As Range, Cell As Range
Dim FormulaSheet As Worksheet
Dim Row As Integer

'创建Range对象
On Error Resume Next
Set FormulaCells = Range("A1").SpecialCells(xlFormulas, 23)

'没有找到公式
If FormulaCells Is Nothing Then
      MsgBox "当前工作表中没有公式！"
      Exit Sub
End If

'增加一个新工作表
Application.ScreenUpdating = False
Set FormulaSheet = ActiveWorkbook.Worksheets.Add
FormulaSheet.Name = "“" & FormulaCells.Parent.Name & "”表中的公式"

'列标题
With FormulaSheet
      Range("A1") = "公式所在单元格"
      Range("B1") = "公式"
      Range("C1") = "值"
      Range("A1:C1").Font.Bold = True
End With

'读取公式，同时在状态栏中显示进度。
Row = 2
For Each Cell In FormulaCells
      Application.StatusBar = Format((Row - 1) / FormulaCells.Count, "0%")
      With FormulaSheet
         Cells(Row, 1) = Cell.Address _
            (RowAbsolute:=False, ColumnAbsolute:=False)
         Cells(Row, 2) = " " & Cell.Formula
         Cells(Row, 3) = Cell.Value
         Row = Row + 1
      End With
Next Cell

'调整列宽
FormulaSheet.Columns("A:C").AutoFit
Application.StatusBar = False
End Sub

Sub 公式还原()
Dim n&
With Sheet2
On Error Resume Next
n = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To n
Sheet1.Range(.Range("A" & i).Value).Formula = Mid(.Range("B" & i).Value, 2, 300)
Next
End With
End Sub

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-6-14 09:24

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

上传

点击文件名下载附件

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", "") & ".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-13 20:24

提取原来的公式，再放入原来的表中好像没什么意义啊，代码如下：

Sub 提取带公式的单元格()
Dim FormulaCells As Range, Cell As Range
Dim FormulaSheet As Worksheet
Dim Row As Integer
Dim dc
'创建Range对象
On Error Resume Next
Set dc = CreateObject("Scripting.Dictionary")
Set FormulaCells = Range("A1").SpecialCells(xlFormulas, 23)
'没有找到公式
If FormulaCells Is Nothing Then
MsgBox "当前工作表中没有公式！"
Exit Sub
End If
'读取公式，同时在状态栏中显示进度。
For Each Cell In FormulaCells
Application.StatusBar = Format((Row - 1) / FormulaCells.Count, "0%")
With FormulaSheet
dc.Add Cell.Address(RowAbsolute:=False, ColumnAbsolute:=False), Cell.Formula
End With
Next Cell
For Each k In dc.keys
Sheet2.Range(k).Formula = dc(k)
Next
Application.StatusBar = False
End Sub

复制代码

乐乐2006201506 · 发表于 2016-6-13 20:30

本帖最后由乐乐2006201506 于 2016-6-13 20:35 编辑

老司机带带我发表于 2016-6-13 20:24
提取原来的公式，再放入原来的表中好像没什么意义啊，代码如下：

您把工作表中的公式提取到哪儿了？
现在再写段代码，将刚才提取的公式还原回来就OK了。
我会在公式提取后删除公式，使整个表格中不含公式，等到下次再用的时候，将公式又还原回来。
谢谢！

老司机带带我 · 发表于 2016-6-13 20:35

乐乐2006201506 发表于 2016-6-13 20:30
您这个把公式提取到哪儿了？
现在再写段代码，将刚才提取的公式还原回来就OK了。
我会在公式提取后删除 ...

你的下次是什么时候？如果是删除之后过一会就调用可以将dc定义为公共变量，然后进行调用，但如果工作簿被关闭或那个代码中断，那缓存也会消失，即公式也会随之消失，这里是存在风险的，还是把公式读取出来存储到其他地方，然后需要时随时进行还原就好了，这样相对安全一点！

乐乐2006201506 · 发表于 2016-6-13 20:49

那麻烦您把公式读取出来存储到另外一个代码中，当我关闭工作簿过段时间（具体间隔不确定）再调用的时候，就可以直接还原公式，谢谢！
当然您直接存入前面您写的那个还原公式代码不是更好吗？（当然这涉及到将提取的公式自动存储到另一代码指定位置的问题，您根据您自己的思路，只要实现我的目的就成）

我现在的思路是：先将某个表格中的所有公式用VBA代码的形式存储起来，然后将表格中所有公式全去除。当我再次想用的时候，再调用代码将原来的公式的还原。

老司机带带我 · 发表于 2016-6-13 20:59

乐乐2006201506 发表于 2016-6-13 20:49
那麻烦您把公式读取出来存储到另外一个代码中，当我关闭工作簿过段时间（具体间隔不确定）再调用的时候，就 ...

存在VBA代码中做不到吧，哪怕用VBE每次写入到代码中我觉得也没这个必要啊，你直接存储在其他的工作表中，然后用的时候去调用不行？

乐乐2006201506 · 发表于 2016-6-13 21:03

本帖最后由乐乐2006201506 于 2016-6-13 21:05 编辑

老司机带带我发表于 2016-6-13 20:59
存在VBA代码中做不到吧，哪怕用VBE每次写入到代码中我觉得也没这个必要啊，你直接存储在其他的工作表中， ...

      那您的意思是，按照前面的那个代码，将公式提取到另一个工作表中，然后还原，是吗？如果是这样的话，那就算了，暂时就将就着用吧！谢谢！
      能不能实现用VBA代码向指定代码指定位置写入指定代码？
下面代码可以实现用代码新增模块，能不能实现红色字体的要求呢？
Sub 新增模块()
Dim I As Long
Dim S As String
On Error Resume Next
Do
      I = I + 1
      S = ThisWorkbook.VBProject.VBComponents("新模块" & I).Name
Loop Until Err
ThisWorkbook.VBProject.VBComponents.Add(1).Name = "新模块" & I
End Sub

老司机带带我 · 发表于 2016-6-13 21:04

乐乐2006201506 发表于 2016-6-13 21:03
那您的意思是，按照前面的那个代码，将公式提取到另一个工作表中，然后还原，是吗？如果是这样的 ...

回头我研究下吧，如果放在特定的TXT文件中回头从中取数是否可行？

乐乐2006201506 · 发表于 2016-6-13 21:09

也可以吧，主要是能实现我想提取的工作表中的公式能够存储到另外一个地方，并将文件命名为和工作表所在工作簿名称相同即可。同时实现可以选择保存位置或保存到指定文件夹。后边的估计容易实现。
希望您能够放在特定的TXT文件中，并按我刚才要求命名，存放到指定位置即可。谢谢啦！

fjmxwrs · 发表于 2016-6-13 21:33

本帖最后由 fjmxwrs 于 2016-6-13 21:35 编辑

乐乐2006201506 发表于 2016-6-13 20:30
您把工作表中的公式提取到哪儿了？
现在再写段代码，将刚才提取的公式还原回来就OK了。
我会在公式提取 ...

有创意，等老师的结果学习一下

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