[求助]如何通过一个工作簿的VBA对新生成的工作簿添加VBA代码？

banjinjiu

同时看了2个同样类型的案例，上个保存了就不行，http://club.excelhome.net/thread-847204-1-1.html
。
初次接触，了解不深，下次耐心看，用心记。这个不错，感谢各位高手。

sunny_8848

hiyou 发表于 2007-10-11 13:19
又发了一次，重复了....多余的编辑掉，留下新加的一点点注释注意黑体的两行，VBCOMPONENTS(1)是取第一个模块 ...

请教，我在练习把代码  x.CodeModule.InsertLines 3, "strMsg=" & Chr(34) & "hello,this is " & mybook.Name & Chr(34) 写入所打开的文件时出错，请问怎样解决（新建工作薄没有问题）。另外，怎样一次性把同样代码写入一个文件夹中的所有文件中？

sunny_8848

正需要这样的功能，多谢讲解

孤独行星双星记

好好学习一下，也许有用。

bearhee

hiyou 发表于 2007-10-12 23:03
AddFromString并不确定插入的位置,它只认定一个字符串,在插入"dim a as string"这个声明时,它自作主张把插入 ...

我也按照你的方法这样写，但为何报错啊，其中显红的几行代码都报错，这是啥问题啊..?

hiyou

bearhee 发表于 2014-7-21 15:40
我也按照你的方法这样写，但为何报错啊，其中显红的几行代码都报错，这是啥问题啊..?

没有附件,只看图的话....

你自已注意一下,报错的都是引号中带引号的语句。
VBA对字符串常量的界定以双引号为标识，你可以这么写

1. strX="aaa'b'"   '<==字符串是aaa'b'，里面用单引号

复制代码

但是呢这样写就出错了

1. strX="aaa"b""  ‘〈＝＝字符串是aaa"b"

复制代码

为什么会错，是因为VBA把后面的表达式识别成
"aaa"  和   b""
在赋值语法上不正确。

要把双引号包含进去，得到   aaa"b"  
需用类似下面的语法
strX="aaa" & chr(34) & "b" & chr(34)   '<==”aaa“的引号是代码识别的引号，chr(34)就是转换的引号，VBA不会认错

以上，领会一下，再看你自已标红的地方

bearhee

hiyou 发表于 2014-7-21 15:56
没有附件,只看图的话....

你自已注意一下,报错的都是引号中带引号的语句。

非常感谢你的提示，对我很有启发，但我按照你的意思改完之后还是报错出来了啊，麻烦帮我看看是不是哪又出错了..谢谢，不甚感激..

hiyou

你用图片......没法粘贴代码真辛苦，

看看你的第一个chr(34) &，被双引号包进去了 &和CHR(34）都没有解析，当成普通字符串 *_*  比如下面的

strX="a&chr(34)&b"                ’〈＝＝得到的字串是 a&chr(34)&b
strX="a" & chr(34) &  "b"        ’〈＝＝得到的字串是 a"b

每一对引号把中间的字符围起来识别，在各个成对引号中间的 &、chr(34) 才是代码
你再看看自已的    pivotables(chr(34)&
真正的连接应该是下面的形式，请再作理解
"xxxx"  & chr(34)  & "oooo"  
"xxxx" + chr(34)  + "oooo"     ‘<==这种不是很推荐，有数字时容易搞混

bearhee

hiyou 发表于 2014-7-21 15:56
没有附件,只看图的话....

你自已注意一下,报错的都是引号中带引号的语句。

Sub addcode()
Set x = ActiveWorkbook.VBProject.VBComponents(1)
strProc = "Private Sub checkbox1_Click()"
strProc = strProc & vbCrLf & "Dim BJ()"
strProc = strProc & vbCrLf & "Dim i As Intege"
strProc = strProc & vbCrLf & "BJ = Array("3001", "3002", "3003", "3004", "3005", "3006", "3007", "3008", "3009", "3010", "3011")"
strProc = strProc & vbCrLf & "On Error Resume Next"
strProc = strProc & vbCrLf & "If CheckBox1.Object.Value = True Then"
strProc = strProc & vbCrLf & "        For i = 1 To UBound(BJ)"
strProc = strProc & vbCrLf &"            With ActiveSheet.PivotTables("PivotTable1").PivotFields("T")"
strProc = strProc & vbCrLf & "                .PivotItems(BJ(i)).Visible = True"
strProc = strProc & vbCrLf & "            End With"
strProc = strProc & vbCrLf & "        Next i"
strProc = strProc & vbCrLf & "    Else"
strProc = strProc & vbCrLf & "        For i = 1 To UBound(BJ)"
strProc = strProc & vbCrLf &"            With ActiveSheet.PivotTables("PivotTable1").PivotFields("T")"
strProc = strProc & vbCrLf & "                .PivotItems(BJ(i)).Visible = False"
strProc = strProc & vbCrLf & "            End With"
strProc = strProc & vbCrLf & "        Next i"
strProc = strProc & vbCrLf & "    End If"
strProc = strProc & vbCrLf & "End Sub"
x.CodeModule.AddFromString strProc
End Sub

朋友，请教下我上面代码中的双引号应该怎么处理，才能不报错...?

hiyou

赋值部分,前面两个标红的错句给你示例,最后一个自已试试.
就是在引号部分断开,用 chr(34) & "内容" & chr(34) 代替

1. strproc = "Private Sub checkbox1_Click()"
   
2. strproc = strproc & vbCrLf & "Dim BJ()"
   
3. strproc = strproc & vbCrLf & "Dim i As Intege"
   
4. strproc = "Private Sub checkbox1_Click()"
   
5. strproc = strproc & vbCrLf & "Dim BJ()"
   
6. strproc = strproc & vbCrLf & "Dim i As Intege"
   
7. 
   
8. strproc = strproc & vbCrLf & "BJ = Array("
   
9. strproc = strproc & vbCrLf & Chr(34) & 3001 & Chr(34) & ","
   
10. strproc = strproc & vbCrLf & Chr(34) & 3002 & Chr(34) & ","
    
11. strproc = strproc & vbCrLf & Chr(34) & 3003 & Chr(34) & ","
    
12. strproc = strproc & vbCrLf & Chr(34) & 3004 & Chr(34) & ","
    
13. strproc = strproc & vbCrLf & Chr(34) & 3005 & Chr(34) & ","
    
14. strproc = strproc & vbCrLf & Chr(34) & 3006 & Chr(34) & ","
    
15. strproc = strproc & vbCrLf & Chr(34) & 3007 & Chr(34) & ","
    
16. strproc = strproc & vbCrLf & Chr(34) & 3008 & Chr(34) & ","
    
17. strproc = strproc & vbCrLf & Chr(34) & 3009 & Chr(34) & ","
    
18. strproc = strproc & vbCrLf & Chr(34) & 3010 & Chr(34)
    
19. 
    
20. strproc = strproc & vbCrLf & "On Error Resume Next"
    
21. strproc = strproc & vbCrLf & "If CheckBox1.Object.Value = True Then"
    
22. strproc = strproc & vbCrLf & "        For i = 1 To UBound(BJ)"
    
23. 
    
24. strproc = strproc & vbCrLf & "            With ActiveSheet.PivotTables("
    
25. strproc = strproc & Chr(34) & "PivotTable1" & Chr(34) & ").PivotFields("
    
26. strproc = strproc & Chr(34) & "T" & Chr(34) & ")"
    
27. 
    
28. MsgBox strproc  '<==这个句子是我加上去的,弹出一个框显示结果,你可以检查

复制代码