关于字典的用法

dogingate

Attribute VB_Name = "Excel模块导出"
'''1、引用Microsoft Visual Basic for Application Extensibility 5.3，
'''2、并且选择信任对VBA工程访问）
Sub ModulesExporting()
Dim strExportFolderPath As String
Dim oVBProj As Object
Dim oVBComp As Object
Dim oExportFolder As Object
Dim strExtName As String
Dim oWb As Object

Set oWb = ThisWorkbook

Set fso = CreateObject("scripting.filesystemobject")

strExportFolderPath = oWb.Path & "\" & "Excel所有模块"

If Not fso.folderexists(strExportFolderPath) Then
    fso.createfolder (strExportFolderPath)
End If

Set zd = CreateObject("scripting.dictionary")

For Each oVBComp In oWb.VBProject.VBComponents
    If Not zd.exists(oVBComp.Name) Then
        Select Case oVBComp.Type
            Case 1
                zd(oVBComp.Name) = oVBComp.Type & "_" & oVBComp.Name & ".bas"
            Case 2
                zd(oVBComp.Name) = oVBComp.Type & "_" & oVBComp.Name & ".cls"
            Case 3
                zd(oVBComp.Name) = oVBComp.Type & "_" & oVBComp.Name & ".frm"
            Case 100
                If oVBComp.CodeModule.CountOfLines > 0 Then
                    If oVBComp.Name <> "ThisWorkbook" Then
                        For Each sht In ThisWorkbook.Worksheets
                            If sht.CodeName = oVBComp.Name Then
                                zd(oVBComp.Name) = oVBComp.Type & "_" & oVBComp.Name & "_" & sht.Name & ".bas"
                            End If
                        Next sht
                    Else
                        zd(oVBComp.Name) = oVBComp.Type & "_" & oVBComp.Name & ".bas"
                    End If
                End If
        End Select
    End If
Next oVBComp

Set oVBProj = ThisWorkbook.VBProject
zdkeys = zd.keys
For i = 0 To zd.Count - 1
    strVBCompName = zdkeys(i)
    oVBProj.VBComponents(strVBCompName).Export strExportFolderPath & "\" & zd(strVBCompName)
Next i

MsgBox "所有模块导出完毕！"

End Sub

dogingate

Attribute VB_Name = "Excel模块更新"
Sub ModulesUpdating()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

Dim oVBProj As Object, oVBComp As Object, oWb As Object
Dim strFilePath As String

Set fso = CreateObject("scripting.filesystemobject")

Set oWb = ThisWorkbook

strFilePath = oWb.Path & "\" & oWb.Name

For i = 1 To Application.VBE.VBProjects.Count
    If Application.VBE.VBProjects(i).Filename = strFilePath Then
        Set oVBProj = Application.VBE.VBProjects(i)
    End If
Next i

Set zd = CreateObject("scripting.dictionary")

For Each oVBComp In oWb.VBProject.VBComponents
    If Not zd.exists(oVBComp.Name) Then
        Select Case oVBComp.Type
            Case 1
                zd(oVBComp.Type & "_" & oVBComp.Name) = oVBComp.CodeModule.Lines(1, oVBComp.CodeModule.CountOfLines)
            Case 2
                zd(oVBComp.Type & "_" & oVBComp.Name) = oVBComp.CodeModule.Lines(1, oVBComp.CodeModule.CountOfLines)
            Case 3
                zd(oVBComp.Type & "_" & oVBComp.Name) = oVBComp.CodeModule.Lines(1, oVBComp.CodeModule.CountOfLines)
            Case 100
                If oVBComp.CodeModule.CountOfLines > 0 Then
                    If oVBComp.Name <> "ThisWorkbook" Then
                        For Each sht In ThisWorkbook.Worksheets
                            If sht.CodeName = oVBComp.Name Then
                                zd(oVBComp.Type & "_" & oVBComp.Name & "_" & sht.Name) = oVBComp.CodeModule.Lines(1, oVBComp.CodeModule.CountOfLines)
                            End If
                        Next sht
                    Else
                        zd(oVBComp.Type & "_" & oVBComp.Name) = oVBComp.CodeModule.Lines(1, oVBComp.CodeModule.CountOfLines)
                    End If
                End If
        End Select
    End If
Next oVBComp
zdkeys = zd.keys

Dim strNewWbPath As String
Dim oNewWb As Object
Dim intVBCompType As Integer

Set fso = CreateObject("scripting.filesystemobject")
With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "请选择Excel文档"
    If .Show = -1 Then
        newWbPath = .SelectedItems(1)
        
        Set oNewWb = Application.Workbooks.Open(newWbPath)
        
        For i = 1 To Application.VBE.VBProjects.Count
            If Application.VBE.VBProjects(i).Filename = newWbPath Then
                Set oVBProj = Application.VBE.VBProjects(i)
            End If
        Next i
        
        
        For Each oVBComp In oVBProj.VBComponents
            Select Case oVBComp.Type
                Case 1, 2, 3
                    oVBProj.VBComponents.Remove oVBProj.VBComponents(oVBComp.Name)  '删除模块、类模块、窗体
                Case 100
                    oVBComp.CodeModule.DeleteLines 1, oVBComp.CodeModule.CountOfLines
            End Select
        Next oVBComp
        
        For i = 0 To zd.Count - 1
            
            zdkey = zdkeys(i)
            arrsplit = Split(zdkey, "_")
            intVBCompType = CInt(arrsplit(0))
            Select Case intVBCompType
                Case 1, 2, 3
                    Set oVBComp = oVBProj.VBComponents.Add(intVBCompType)
                    oVBComp.Name = arrsplit(1)
                    oVBComp.CodeModule.AddFromString zd(zdkey)
                Case 100
                    If arrsplit(1) <> "ThisWorkBook" Then
                        oVBProj.VBComponents(arrsplit(1)).CodeModule.AddFromString zd(zdkey)
                    Else
                        oVBProj.VBComponents(arrsplit(1)).CodeModule.AddFromString zd(zdkey)
                    End If
            End Select
            
        Next i
        
        oNewWb.Close True
        
    Else
        Exit Sub
    End If
End With

MsgBox "所有模块更新完毕！"

End Sub

dogingate

帮助文档详见附件

nongo

         谢谢分享

dogingate

有的时候如果没有引用visubl basic for entensibility的话，就无法导出模块，但每次都要自己添加有点麻烦的，可以用references.addfromfile来解决，详见代码

WalkerOn

值得收藏的帖子

wggx4

好像现在还是不懂字典怎么入门，慢慢看，争取早点入门。

hahahaha0001

学习了。练习练习再说。

E_菜鸟

非常感谢楼主分享

dogingate

这是使用字典的一个例子，字典的好处就是快速查找，判断是否有相同的key，再做进一步处理