设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 怎样批量向本文件夹下的所有文件中的"thisWorkbook" ...
数据透视表40+个常用小技巧，让你一次学会！
12下一页
返回列表 发新帖
查看: 4864|回复: 14

[已解决]怎样批量向本文件夹下的所有文件中的"thisWorkbook"中添加相同的代码？

[复制链接]
发表于 2012-7-1 13:23 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
请教：怎样批量向本文件夹下的所有文件中的"thisWorkbook"中添加相同的代码？谢谢！
比如说我想一次性向一个文件夹中所有文件中的"thisWorkbook"中添加下面的代码：
Private Sub Workbook_Open()
    Dim x As Date    '指定日期
    Dim shName As String    '指定工作表的名称
    Dim sh As Worksheet
    x = #12/25/2012#
    shName = "Sheet3"
    If Date <> x Then End
   
    Application.DisplayAlerts = False
    For Each sh In Sheets
        If sh.Name <> shName Then sh.Visible=xlSheetVeryHidden
    Next
End Sub

最佳答案
月排行榜 / 总排行榜
zjdh
2012-7-1 15:49
本帖最后由 zjdh 于 2012-7-1 15:50 编辑

试了一下2003可以，2007被拒绝：
  1. Sub 写入宏()
  2.     On Error Resume Next
  3.     S = "Private Sub Workbook_Open()" _
  4.       & Chr(10) _
  5.       & "Dim x As Date" _
  6.       & Chr(10) _
  7.       & "Dim shName As String" _
  8.       & Chr(10) _
  9.       & "Dim sh As Worksheet" _
  10.       & Chr(10) _
  11.       & "x = #12/25/2012#" _
  12.       & Chr(10) _
  13.       & "shName = ""Sheet3""" _
  14.       & Chr(10) _
  15.       & "If Date <> x Then End" _
  16.       & Chr(10) _
  17.       & "Application.DisplayAlerts = False" _
  18.       & Chr(10) _
  19.       & "For Each sh In Sheets" _
  20.       & Chr(10) _
  21.       & "If sh.Name <> shName Then sh.Visible = xlSheetVeryHidden" _
  22.       & Chr(10) _
  23.       & "Next" _
  24.       & Chr(10) _
  25.       & "End Sub"
  26.     Application.ScreenUpdating = False
  27.     Dirs = Dir(ThisWorkbook.Path & "\*.xls")
  28.     While Dirs <> ""
  29.         If ThisWorkbook.Name <> Dirs Then
  30.             Workbooks.Open (ThisWorkbook.Path & "" & Dirs)
  31.             For Each m In ActiveWorkbook.VBProject.VBComponents
  32.                 If m.Name = "ThisWorkbook" Then
  33.                     m.CodeModule.AddFromString S
  34.                     Exit For
  35.                 End If
  36.             Next
  37.             ActiveWorkbook.Close True
  38.         End If
  39.         Dirs = Dir
  40.     Wend
  41.     Application.ScreenUpdating = True
  42.     MsgBox "操作完毕!"
  43. End Sub
复制代码
文件夹

相关帖子
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
发表于 2012-7-1 14:39 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
想做病毒？
回复

使用道具 举报

zjdh
发表于 2012-7-1 15:49 | 显示全部楼层    本楼为最佳答案   
工作中最常用的Excel函数公式，全印在一张鼠标垫上
本帖最后由 zjdh 于 2012-7-1 15:50 编辑

试了一下2003可以，2007被拒绝：
  1. Sub 写入宏()
  2.     On Error Resume Next
  3.     S = "Private Sub Workbook_Open()" _
  4.       & Chr(10) _
  5.       & "Dim x As Date" _
  6.       & Chr(10) _
  7.       & "Dim shName As String" _
  8.       & Chr(10) _
  9.       & "Dim sh As Worksheet" _
  10.       & Chr(10) _
  11.       & "x = #12/25/2012#" _
  12.       & Chr(10) _
  13.       & "shName = ""Sheet3""" _
  14.       & Chr(10) _
  15.       & "If Date <> x Then End" _
  16.       & Chr(10) _
  17.       & "Application.DisplayAlerts = False" _
  18.       & Chr(10) _
  19.       & "For Each sh In Sheets" _
  20.       & Chr(10) _
  21.       & "If sh.Name <> shName Then sh.Visible = xlSheetVeryHidden" _
  22.       & Chr(10) _
  23.       & "Next" _
  24.       & Chr(10) _
  25.       & "End Sub"
  26.     Application.ScreenUpdating = False
  27.     Dirs = Dir(ThisWorkbook.Path & "\*.xls")
  28.     While Dirs <> ""
  29.         If ThisWorkbook.Name <> Dirs Then
  30.             Workbooks.Open (ThisWorkbook.Path & "" & Dirs)
  31.             For Each m In ActiveWorkbook.VBProject.VBComponents
  32.                 If m.Name = "ThisWorkbook" Then
  33.                     m.CodeModule.AddFromString S
  34.                     Exit For
  35.                 End If
  36.             Next
  37.             ActiveWorkbook.Close True
  38.         End If
  39.         Dirs = Dir
  40.     Wend
  41.     Application.ScreenUpdating = True
  42.     MsgBox "操作完毕!"
  43. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2012-7-1 19:08 | 显示全部楼层
本帖最后由 小雨饰品 于 2012-7-1 19:09 编辑
zjdh 发表于 2012-7-1 15:49
试了一下2003可以，2007被拒绝：

谢谢博士的指导。完全达到我的想法。
谢谢！顺便再请教一下，如何逆向操作，即：批量删除本文件夹下的所有文件中的代码？
回复

使用道具 举报

zjdh
发表于 2012-7-1 20:02 | 显示全部楼层
小雨饰品 发表于 2012-7-1 19:08
谢谢博士的指导。完全达到我的想法。
谢谢！顺便再请教一下，如何逆向操作，即：批量删除本文件夹下的所 ...

另外发贴吧         
.
回复

使用道具 举报

 楼主| 发表于 2012-7-2 09:05 | 显示全部楼层
zjdh 发表于 2012-7-1 20:02
另外发贴吧         
.

好的，谢谢！！！！！！
回复

使用道具 举报

 楼主| 发表于 2012-7-2 16:02 | 显示全部楼层
zjdh 发表于 2012-7-1 20:02
另外发贴吧         
.

我重新发了一个帖子，有时间时帮我看看，谢谢！
http://www.excelpx.com/thread-250005-1-1.html
回复

使用道具 举报

wqsk001
发表于 2020-2-24 10:17 | 显示全部楼层
zjdh 发表于 2012-7-1 15:49
试了一下2003可以，2007被拒绝：

求个2010的代码，文件格式.xlsm,谢谢
回复

使用道具 举报

zjdh
发表于 2020-2-24 13:21 | 显示全部楼层
Book.rar (48.19 KB, 下载次数: 8)
回复

使用道具 举报

wqsk001
发表于 2020-2-24 20:59 | 显示全部楼层
本帖最后由 wqsk001 于 2020-2-24 21:12 编辑
zjdh 发表于 2020-2-24 13:21

谢谢大神！这个刚才测试了一下，可以用。不过只能用于当前目录下的文件，看能不能帮着再改进一下，把子目录下的文件一块也给改了，拜谢了，在线等。
下面的这个代码经测试也是成功的（代码也是我在论坛找的）。这个代码麻烦的地方是要一个一个的手工去选文件。好处在于不用把代码写到模块里，且带有删除更新功能。找出来供大神参考一下
Sub Update()
    Dim F
    Dim Cl As Object
    Dim I As Long, N As Long
    Dim Ar() As String
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False    '防止open close 等事件触发
    '*****************************************************************
    '获取新代码
    ReDim Ar(ThisWorkbook.VBProject.VBComponents.Count, 2)
    For Each Cl In ThisWorkbook.VBProject.VBComponents
        If m.Name <> "Update" Then  '不读取本模块代码
            Ar(N, 1) = Cl.Name
            Ar(N, 2) = Cl.CODEMODULE.Lines(1, Cl.CODEMODULE.COUNTOFLINES)
            N = N + 1
        End If
    Next
    '*****************************************************************
    '获取待更新文件
    F = Application.GetOpenFilename("Excel(*.xls*),*.xls*", , "选择要更新的文件", , False)
    If F = False Then Exit Sub
    '*****************************************************************
    '打开待更新文件，删除旧代码，写入新代码
    With Workbooks.Open(F)
        With .VBProject
            For I = 0 To N - 1
                Set Cl = Nothing
                Set Cl = .VBComponents(Ar(I, 1))
                If Not Cl Is Nothing Then
                    With Cl.CODEMODULE
                        .DELETELINES 1, .COUNTOFLINES
                        .ADDFROMSTRING Ar(I, 2)
                    End With
                End If
            Next
        End With
    '*****************************************************************
    ' XLSX 文件需要另存为启用宏的工作表 XLSM 格式
        If UCase(Right(F, 4)) = "XLSX" Then
            .SaveAs Left(F, Len(F) - 5), 52
            'Kill F   '删除 XLSX 格式原文件
       Else
            .Save
        End If
        .Close True
    End With
    Application.EnableEvents = True
End Sub



回复

使用道具 举报

下一页 »
12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-24 10:36 , Processed in 0.360674 second(s), 13 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表