VBA Express : Excel - VBA Code Library, Attachment includes 75 code examples

Excel

VBA Code Library, Attachment includes 75 code examples

Ease of Use

Easy

Version tested with

2000,2003

Submitted by:

johnske

Description:

You can import and export code modules and userforms or run procedures.

Discussion:

It's often a pain to search through workbooks to find a handy procedure you might want to use somewhere else. This Excel code library allows you to save all these handy snippets of code, userforms, and class modules in one location. you can then view the code or run it to see whether it suits what you want to do now. (Note that you can also save your Word, Outlook, etc. modules in here but you generally won't be able to run them).... MOST of the examples in the attachment are my own code but there are a few that I have picked up from various places. Please note that I often lose track of where I get code samples from, so if you do recognize code that may perhaps be 'yours' and it has not been acknowledged therein as such, my sincerest apologies to you, but you do have the small consolation that it has been recognized as being a useful, neat, or otherwise handy piece of code worthy of inclusion in a 'library' by a wannabe coder ) ... The code for the library (below) caters for up to 200 procedures, I think if you have any more than that it will become hard to find a given procedure and it would be more advisable to make another library (a copy) to include any further code. NOTE THAT THE CODE BELOW IS FOR YOU TO CREATE YOUR OWN LIBRARY FROM SCRATCH. IT'S ADVISABLE TO JUST DOWNLOAD THE ATTACHMENT AND REMOVE ANY CODE YOU DON'T WANT.

Code:

instructions for use

			 '***************************************************
 '***************************************************
 
 '<< PASTE INTO THE "ThisWorkbook" MODULE >>
 
Option Explicit 
 
Private Sub Workbook_Activate() 
    Sheet3.Activate 
    Sheet3.Name = "VB Components" 
    Windows.Arrange 
    With ActiveWindow 
        .SmallScroll ToLeft:=256 
        .SmallScroll Up:=65536 
    End With 
    On Error Resume Next '< error = reference already set
     'set reference to Microsoft Visual Basic for Applications
     'Extensibility 5.3
    ThisWorkbook.VBProject.References.AddFromGuid _ 
    "{0002E157-0000-0000-C000-000000000046}", 5, 3 
End Sub 
 
 '***************************************************
 '***************************************************
 
 
 
 '***************************************************
 '***************************************************
 
 '<< PASTE INTO THE "Sheet3" MODULE >>
 
Option Explicit 
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
    Dim N& 
    If Target.row = 1 Then Exit Sub 
     'close any visible modules
    On Error Resume Next '< already minimized
    For N = 1 To ActiveWorkbook.VBProject.VBComponents.Count 
        Application.VBE.Windows(N).WindowState = vbext_ws_Minimize 
    Next 
     'view a procedure
    On Error Goto SelectModule '< next line errors out for forms
    Application.Goto Target.Text 
    Application.VBE.ActiveWindow.WindowState = vbext_ws_Maximize 
    Goto Finish 
SelectModule: 
    On Error Resume Next 
    If Target.Column = 1 Or Target.Column = 2 Or Target.Column = 2 Or Target.Column = 3 Then 
         'select a module
        Application.ScreenUpdating = False 
        ActiveCell.Rows.EntireRow.Columns(1).Select 
        If Selection = Empty Then 
            Do Until Selection <> Empty 
                ActiveCell.offset(-1, 0).Activate 
            Loop 
        End If 
         'view a module
        ThisWorkbook.VBProject.VBComponents _ 
        (Selection).CodeModule _ 
        .CodePane.Show 
        Application.VBE.ActiveWindow.WindowState = vbext_ws_Maximize 
    End If 
Finish: 
End Sub 
 
 '***************************************************
 '***************************************************
 
 
 
 '***************************************************
 '***************************************************
 
 '<< PASTE INTO THE "Userform1" MODULE >>
Option Explicit 
 
Private Sub UserForm_Activate() 
    Dim MyList$(200, 1) 
    Dim Count&, M&, N& 
    Dim Component As VBComponent 
    Height = 302 
    Width = 205 
    With ListBox1 
        .BoundColumn = 0 
        .ColumnWidths = "200" 
        .Font = "Tahoma" 
        .Font.Size = 9 
        .Left = 10 
        .Top = 10 
        .Height = 300 
        .Width = 200 
    End With 
     '************************************************
    If Sheet3.[IV1] = "RunCode" Then 
        Caption = "Run Code (Single-Click)" 
        ListBox1.ControlTipText = "Click the macro you want to run" 
         '//heading
        MyList(0, 0) = "PROCEDURES" 
         '//define list
        For N = 1 To 200 
            MyList(N, 0) = Sheet3.[B1].offset(N, 0) 
        Next 
         '//load list to listbox
        ListBox1.List = MyList 
        DoEvents 
        Exit Sub 
         '************************************************
    ElseIf Sheet3.[IV1] = "ExportCode" Then 
        Caption = "Export Code Module (Double-Click)" 
        ListBox1.ControlTipText = "DOUBLE-Click the module you want to export" 
        MyList(0, 0) = "COMPONENT NAME" 
        N = 1 
        For Each Component In ActiveWorkbook.VBProject.VBComponents 
            MyList(N, 0) = Component.Name 
            N = N + 1 
        Next 
        ListBox1.List = MyList 
        DoEvents 
        Exit Sub 
         '************************************************
    ElseIf Sheet3.[IV1] = "RemoveCode" Then 
        Caption = "Remove Code Module (Double-Click)" 
        ListBox1.ControlTipText = "DOUBLE-Click the module you want to remove" 
         '//heading
        MyList(0, 0) = "COMPONENT NAME" 
        N = 1 
        For Each Component In ActiveWorkbook.VBProject.VBComponents 
            Select Case N 
            Case 1 To 5 
                 'don't list 1 to 5
            Case Else 
                MyList(N - 5, 0) = Component.Name 
            End Select 
            N = N + 1 
        Next 
        ListBox1.List = MyList 
        DoEvents 
        Exit Sub 
         '************************************************
    End If 
End Sub 
 
Private Sub listbox1_Click() 
    If Sheet3.[IV1] <> "RunCode" Then Exit Sub 
    UserForm1.Hide 
     'run the code
    If ListBox1.Text = "RunTheCode" Then 
        MsgBox "Creates infinite loop - not advisable" 
        Set UserForm1 = Nothing 
        Exit Sub 
    ElseIf ListBox1.Text = Empty Then 
        MsgBox "? You selected (blank) ?" 
        Set UserForm1 = Nothing 
        Exit Sub 
    Else 
        On Error Goto ErrorMsg 
        Run (ListBox1.Text) 
         'unload the form
        Unload Me 
        DoEvents 
        Exit Sub 
    End If 
ErrorMsg: 
    MsgBox "Sorry, this can't be 'run' as such, " & ListBox1.Text & " is" & vbLf & _ 
    "either a Function, Userform, or Class procedure..." 
    Set UserForm1 = Nothing 
    Exit Sub 
End Sub 
 
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) 
    Dim N& 
    If Sheet3.[IV1] = "ExportCode" Then 
        With ThisWorkbook.VBProject 
            For N = 1 To .VBComponents.Count 
                If .VBComponents(N).Name = ListBox1.Text Then 
                    Application.VBE.ActiveVBProject.VBComponents(N) _ 
                    .Export (ActiveWorkbook.path & "\" & _ 
                    ListBox1.Text & ".bas") 
                    MsgBox .VBComponents(N).Name & " exported to " & _ 
                    ActiveWorkbook.path 
                    Exit For 
                End If 
            Next N 
        End With 
        Unload Me 
    ElseIf Sheet3.[IV1] = "RemoveCode" Then 
        Dim Query As VbMsgBoxResult 
        With ActiveWorkbook.VBProject 
            For N = 1 To .VBComponents.Count 
                If .VBComponents(N).Name = ListBox1.Text Then 
                    Query = MsgBox("Are you sure? This will delete " & _ 
                    .VBComponents(N).Name, vbYesNo, _ 
                    "Remove Module?") 
                    If Query = vbNo Then Goto Cancelled 
                    .VBComponents.Remove .VBComponents(N) 
                    Exit For 
                End If 
            Next 
        End With 
        MousePointer = fmMousePointerHourGlass 
         'if a module is removed update the list
        If Cancel = False Then UPDATELIST 
        Unload Me 
        Exit Sub 
Cancelled: 
        Unload Me 
    End If 
End Sub 
 
 '***************************************************
 '***************************************************
 
 
 
 '***************************************************
 '***************************************************
 
 '<< PASTE INTO THE "Module1" MODULE >>
Option Explicit 
 
Sub ImportCodeModule() 
    Dim Filt$, Title$, FileName$, Message As VbMsgBoxResult 
    Do 
        Filt = "VB Files (*.bas; *.frm; *.cls)(*.bas; *.frm; *.cls),*.bas;*.frm;*.cls" 
        Title = "SELECT A FOLDER - CLICK OPEN TO IMPORT - CANCEL TO QUIT" 
        FileName = Application.GetOpenFilename(FileFilter:=Filt, FilterIndex:=5, Title:=Title) 
        On Error Goto Finish 
        Application.VBE.ActiveVBProject.VBComponents.Import (FileName) 
        Message = MsgBox(FileName & vbCrLf & " has been imported - more imports?", vbYesNo, "More Imports?") 
    Loop Until Message = vbNo 
    UPDATELIST 
Finish: 
    Message = vbYes 
End Sub 
 
Sub ExportCodeModule() 
    Sheet3.[IV1] = "ExportCode" 
    UserForm1.Show 
End Sub 
 
Sub RemoveCodeModule() 
    Sheet3.[IV1] = "RemoveCode" 
    UserForm1.Show 
End Sub 
 
Sub RunTheCode() 
    Sheet3.[IV1] = "RunCode" 
    UserForm1.Show 
End Sub 
 
Sub UPDATELIST() 
    Dim N&, Count&, Typ& 
    Dim Component As VBComponent 
    Application.ScreenUpdating = False 
    Sheet3.Name = "VB Components" 
    Sheets("VB Components").Activate 
    Cells.ClearContents 
    Cells.Font.Size = 8 
    With Rows("1:1") 
        .Font.Size = 9 
        .Font.Bold = True 
        .Font.ColorIndex = 9 
        .Font.Underline = xlUnderlineStyleSingle 
    End With 
    [A1] = "COMPONENT NAME" 
    [B1] = "PROCEDURES" 
    [C1] = "COMPONENT TYPE" 
    N = 2 
    For Each Component In ThisWorkbook.VBProject.VBComponents 
        Range("A" & N) = Component.Name 
        Typ = Component.Type 
        If Typ = 1 Then Range("C" & N) = "Bas Module" 
        If Typ = 2 Then Range("C" & N) = "Cls Module" 
        If Typ = 3 Then Range("C" & N) = "UserForm" 
        If Typ = 11 Then Range("C" & N) = "ActiveX" 
        If Typ = 100 Then Range("C" & N) = "Book/Sheet Cls Module" 
        With Component.CodeModule 
            Count = .CountOfDeclarationLines + 1 
            Do Until Count >= .CountOfLines 
                Range("B" & N) = .ProcOfLine(Count, vbext_pk_Proc) 
                Count = Count + .ProcCountLines(.ProcOfLine _ 
                (Count, vbext_pk_Proc), vbext_pk_Proc) 
                If Count < .CountOfLines Then N = N + 1 
            Loop 
        End With 
        N = N + 1 
    Next 
    Columns.AutoFit 
    DoBorders 
    ActiveWorkbook.Save 
End Sub 
 
Sub DoBorders() 
    With [A1:C500] 
        With .Borders(xlEdgeLeft) 
            .LineStyle = xlContinuous 
            .Weight = xlHairline 
            .ColorIndex = 15 
        End With 
        With .Borders(xlEdgeTop) 
            .LineStyle = xlContinuous 
            .Weight = xlHairline 
            .ColorIndex = 15 
        End With 
        With .Borders(xlEdgeBottom) 
            .LineStyle = xlContinuous 
            .Weight = xlHairline 
            .ColorIndex = 15 
        End With 
        With .Borders(xlEdgeRight) 
            .LineStyle = xlContinuous 
            .Weight = xlHairline 
            .ColorIndex = 15 
        End With 
        With .Borders(xlInsideVertical) 
            .LineStyle = xlContinuous 
            .Weight = xlHairline 
            .ColorIndex = 15 
        End With 
        With .Borders(xlInsideHorizontal) 
            .LineStyle = xlContinuous 
            .Weight = xlHairline 
            .ColorIndex = 15 
        End With 
    End With 
End Sub 
 
 '***************************************************
 '***************************************************

How to use:

(Note: it's easiest to just download the attachment and use it, however if you want to do all this yourself ) )....
Open an Excel workbook
Select Tools/Macro/Visual Basic Editor
In the VBE window, select View/Project Explorer
Select the 'ThisWorkbook' Module, copy and paste the code for it from above
Now place the mouse pointer anywhere inside this code, and click
Run/Run Sub/UserForm in the VBE toolbar (this sets a required reference)
Select the 'Sheet3' Module, copy and paste the code for it from above
Now select Insert/Userform (this will create Userform1)
In the Toolbox shown, click 'listbox', now put the mouse pointer near the top left of the Userform and move the pointer down and to the right to create ListBox1
Double-click either the listbox or userform and a code pane will appear
Delete any code in this code pane and copy and paste the code for Userform1 from above
Select Insert/Module, copy and paste the code for it from above
Now select File/Close and Return To Microsoft Excel
Save your work

Test the code:

First select Tools/Macro/Macros.../UPDATELIST/Run to list the modules to initialize...
You now have any of the following choices
Select Tools/Macro/Macros.../ImportCodeModule/Run to import modules
Select Tools/Macro/Macros.../ExportCodeModule/Run to export modules
Select Tools/Macro/Macros.../RemoveCodeModule/Run to remove modules
Select Tools/Macro/Macros.../RunTheCode/Run to run code contained in the modules (CAUTION: It's up to you, the coder, to ensure that any code you've imported will not delete or otherwise inadvertently alter wanted sheets in the library if you choose to run the code inside it)

Sample File:

VBAcodeLibrary.zip 109.03KB

Approved by mdmackillop

This entry has been viewed 1584 times.