[已解决]如何将宏导入到新的工作表当中去

qjsu

hwc2ycy 发表于 2013-6-7 19:10
我在自己的电脑上测试了是可以生成的。

另外我不知道你用什么版本，我这测试的是10.

真是万分感谢，代码小小的修改了一下更加适合我，想学习的同学看下面的代码
这个代码我还有很多看不懂的地方，我要仔细研究研究
再次感谢烟花老师
Option Explicit
Dim str As String

Sub FindFile()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.AutomationSecurity = msoAutomationSecurityLow

    With ThisWorkbook.VBProject.VBComponents("模块1").CodeModule
        str = .Lines(1, .CountOfLines)
    End With
    Dim strPath$, strFileName$
    Call TrustVBA
    strPath = ThisWorkbook.Path & Application.PathSeparator
    strFileName = Dir(strPath & "*.xls*")
    Do While Len(strFileName) > 0
        If strFileName <> ThisWorkbook.Name And strFileName Like "*.xls*" Then Call OpenWorkbook(strPath & strFileName)    ':Debug.Print strFileName
        strFileName = Dir
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.AutomationSecurity = msoAutomationSecurityByUI
    MsgBox "完成"
End Sub
Sub OpenWorkbook(strFullname As String)
    Dim wb As Workbook
    On Error GoTo ErrorHandler
    Set wb = GetObject(strFullname)
    With wb
        Debug.Print wb.Name
        Windows(wb.Name).Visible = True
        With .VBProject.VBComponents.Add(1).CodeModule
            .DeleteLines 1, .CountOfLines
            .InsertLines 1, str
        End With
        .SaveAs Left(strFullname, InStrRev(strFullname, ".") - 1) & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
        With .Worksheets(2).Shapes
            With .AddFormControl(Type:=xlButtonControl, Left:=188, Top:=35, Width:=113.25, Height:=36.75).DrawingObject
                .Caption = "合并文档"
                .OnAction = "'" & wb.Name & "'!合并文档"
            End With
            With .AddFormControl(Type:=xlButtonControl, Left:=188, Top:=104, Width:=113.25, Height:=36.75).DrawingObject
                .Caption = "工作表重命名"
                .OnAction = "'" & wb.Name & "'!工作表重命名"
            End With
        End With
        .Close True
    End With
    Exit Sub
ErrorHandler:
    MsgBox prompt:=Err.Number & vbCrLf & Err.Description, Buttons:=vbOKOnly + vbCritical, Title:=wb.Name
    Err.Clear
    Resume Next
End Sub
Sub TrustVBA(Optional ByVal KeyValue = 1)
    Dim strKey1 As String, strKey3 As String
    Dim KeyValue1, KeyValue2
    Dim strVersion As String
    On Error Resume Next
    strVersion = Application.Version
    strKey1 = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & strVersion & "\Excel\Security\AccessVBOM"
    strKey3 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" & strVersion & "\Excel\Security\AccessVBOM"
    'AccessVBOM 允许访问VBA对象
    Call WriteReg(strKey1, KeyValue, "REG_DWORD")
    Call WriteReg(strKey3, KeyValue, "REG_DWORD")
    Exit Sub
End Sub
Sub WriteReg(strkey As String, Value As Variant, ValueType As String)
    Dim objWshell As Object
    On Error Resume Next
    Set objWshell = CreateObject("WScript.Shell")
    If ValueType = "" Then
        objWshell.RegWrite strkey, Value
    Else
        objWshell.RegWrite strkey, Value, ValueType
    End If
    Set objWshell = Nothing
    Err.Clear
    Exit Sub
End Sub

qjsu

hwc2ycy 发表于 2013-6-7 19:23
DIR("*.xls“)
好像是可以搜索XLSM，XLSX格式的，我是下面加了个LIKE "*.xls"过滤了。

搜索不了XLSX，我用的是07，后面不加*号就木有反应

qjsu

hwc2ycy 发表于 2013-6-7 18:46
我这这只测了几个文件。

大量的测试工作就交得你了，有问题尽管说。

Sub TrustVBA(Optional ByVal KeyValue = 1)
Sub WriteReg(strkey As String, Value As Variant, ValueType As String)
烟花老师，我还想问一下这两段是干嘛用的？
PS:他们为什么叫你做烟花捏？

hwc2ycy

qjsu 发表于 2013-6-7 19:37
Sub TrustVBA(Optional ByVal KeyValue = 1)
Sub WriteReg(strkey As String, Value As Variant, ValueT ...

开启VBA模型访问，否则操作不了VBE。

hwc2ycy

qjsu 发表于 2013-6-7 19:25
搜索不了XLSX，我用的是07，后面不加*号就木有反应

奇怪耶，我再试试，我记得我当时好像能搜到，我再测试。

hwc2ycy

你看我图中红线圈住的地方，确实能搜出扩展名中含xls的。