Move the Excel VBA Code from One Workbook to Another.

Hi All,

Recently, I wanted to move VBA Code from one workbook to another. I didn't have any idea. So my teammate did me a favor and got me the following code. So I thought that it is good to share it with the outside world. Moreover, it also moves the code with the Forms as well.

The function expects two parameters,

sourceBook: the workbook where we have to copy the code from
destBook : the workbook where the code has to be copied to

Sub MoveVBACode(sourceBook As Workbook, destBook As Workbook)

    Dim sourceVbComp As VBIDE.VBComponents
    Dim destVbComp As VBIDE.VBComponents


    Dim vbComp As VBComponent


    'To check the code is protected or not
    If sourceBook.VBProject.Protection = vbext_pp_locked Then
        MsgBox "Can't copy code because Source project code is password protected", vbInformation
        Exit Sub
    End If

    Set sourceVbComp = sourceBook.VBProject.VBComponents
    Set destVbComp = destBook.VBProject.VBComponents

    'To copy the modules from source to destination
    For Each vbComp In sourceVbComp
        If vbComp.Type = vbext_ct_Document Then
            CopyModule vbComp, destVbComp, ""
        ElseIf vbComp.Type = vbext_ct_StdModule Then
            CopyModule vbComp, destVbComp, ".bas"
        ElseIf vbComp.Type = vbext_ct_MSForm Then
            CopyModule vbComp, destVbComp, ".frm"
        ElseIf vbComp.Type = vbext_ct_ClassModule Then
            CopyModule vbComp, destVbComp, ".cls"
        End If
    Next

End Sub

Function CopyModule(sourceVbComp As VBIDE.VBComponent, _
                    destVbComp As VBIDE.VBComponents, _
                    extn As String)
    
Dim fName As String
Dim vbComp As VBIDE.VBComponent
Dim destCodeMod As VBIDE.CodeModule
Dim codeText As String
Dim destCodeModule As Variant
Dim TempVBComp As Variant

Const filePath As String = "C:\"
Const xportPath As String = "C:\Temp\"
    
    fName = xportPath & sourceVbComp.Name & extn
    
    sourceVbComp.Export fName
    
    If sourceVbComp.Type = vbext_ct_Document Then
    'To copy the code form ThisWorkbook and sheets
        
        'To get the code module in the destination file
        For Each vbComp In destVbComp
            If vbComp.Type = vbext_ct_Document And vbComp.Name = sourceVbComp.Name Then
                Set destCodeModule = vbComp.CodeModule
                Exit For
            End If
        Next
        
        'To update the code from source to destination
        If Not destCodeModule = "" Then
            Set TempVBComp = destVbComp.Import(fName)
            With destCodeModule
                If TempVBComp.CodeModule.CountOfLines > 0 Then
                     codeText = TempVBComp.CodeModule.Lines(1, TempVBComp.CodeModule.CountOfLines)
                    .InsertLines 1, codeText
                End If
            End With
              destVbComp.Remove TempVBComp
        End If
        
    Else ' For modules ,forms and classes
        destVbComp.Import fName
    End If
        
    'To kill the exported file
    Kill fName

End Function

Thanks,
Vikas

Move all worksheets from a workbook to another

Hi,

Ever moved all the worksheets from a workbook to another. I did it previously, so thought to share the code with you all.

Public Sub CopyWorksheets(sourceBook As Workbook, destBook As Workbook)
   
    Dim shtCounter As Integer
    Dim wkSheet As Worksheet
    
    'remove all the sheets from Destination workbook except one.
    'the last worksheet will be deleted once we have copied the worksheets
    
    For shtCounter = destBook.Worksheets.Count To 2 Step -1
        Set wkSheet = destBook.Worksheets(shtCounter)
        Application.DisplayAlerts = False
        wkSheet.Delete
        Application.DisplayAlerts = True
    Next shtCounter
    
    'rename the sheet1 so that we can assure there is no duplicity
    
    Set wkSheet = Worksheets(1)
    
    wkSheet.Name = "123111xSheet111789" 'giving some arbit name so that we can
                                        ' assure that the sheets we are trying
                                        'copy doesn't have the same name as the worksheet's name.
    
    'copy sheets to destWKB
    
    sourceBook.Worksheets.Copy after:=destBook.Worksheets(1)
    
    
    
    Application.DisplayAlerts = False
    wkSheet.Delete
    Application.DisplayAlerts = True
End Sub

HTH,
Vikas Bhandari

Excel - Break External Links

Hi All,

Please find below the code for Breaking the external links from a Workbook.

Public Sub BreakLinks()
    Dim aLinks As Variant
    Dim i As Integer
    Dim sht As Worksheet
    
    aLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
    If Not IsEmpty(aLinks) Then
        For i = 1 To UBound(aLinks)
            ActiveWorkbook.BreakLink Name:=aLinks(i), Type:=xlExcelLinks
        Next i
    End If
End Sub

Hope this helps.

Thanks,
Vikas

Allow User to Enter Data in a Protected Sheet

Hi All,

We know that we can protect a worksheet so that user should not able to touch any of values in cell. You can protect the sheet by going to Review Tab --> Protect Sheet option. The option is shown in the following screenshot:



This is easy. But what if we want to allow user to enter data in some of the cells. Or if we want to open few of the cells to the user where he/she can enter his/her inputs.

Protection on a worksheet works only for those cells which are Locked. By default, every cell in a worksheet is locked so when a user protects a worksheet, all of the cells are locked by default. Vice versa, if a cell is not locked then user can edit the data even if the worksheet is protected. So to allow few of the cells to be unlocked(so that these can remain unprotected), we first need to remove the locked option from the cells. Following are the steps given to achieve this :

--> Select the cell which you want to unlock
--> Right click on that cell and click on Format Cells. It is displayed in the following screenshot :



--> Go to the protection Tab, and uncheck the "Locked" option. See the following screenshot:



If you keep this option unchecked for a cell/range, the cell/range cannot be protected. So if you want to keep few of cells open for user in a protected sheet, you can use the above mentioned procedure.

Hope this helps :)

Thanks,
Vikas

Find Last Cell, Column And Row in Excel Worksheet

Hi All,

Please find below a small code snippet, which you can use to find the last Used Cell, Row or Column.

Public Function LastUsedCell() As Range
    Dim rng As Range
    Dim activeSht As Worksheet
    On Error GoTo ErrHandler
    
    Set activeSht = activeSheet

    Set rng = activeSht.Range("A1").SpecialCells(xlCellTypeLastCell)
    
    'return value
    Set LastUsedCell = rng
    Exit Function
ErrHandler:
    Set LastUsedCell = Nothing
End Function

Public Function LastUsedRow() As Long
    Dim rng As Range
    Dim activeSht As Worksheet
    On Error GoTo ErrHandler
    
    Set activeSht = activeSheet

    Set rng = activeSht.Range("A1").SpecialCells(xlCellTypeLastCell)
    
    'return value
    LastUsedRow = rng.Row
    Exit Function
ErrHandler:
    LastUsedRow = 0

End Function


Public Function LastUsedColumn() As Integer
    Dim rng As Range
    Dim activeSht As Worksheet
    On Error GoTo ErrHandler
    
    Set activeSht = activeSheet

    Set rng = activeSht.Range("A1").SpecialCells(xlCellTypeLastCell)
    
    'return value
    LastUsedColumn = rng.Column
    Exit Function
ErrHandler:
    LastUsedColumn = 0

End Function

Hope this helps :)

Thanks,
Vikas

Excel VBA : Loop through all the files and subfolders in a Folder

Hi All,

I write this function many many times in my projects. When we have to create a temporary folder which are specific to our application, then I normally have to loop through all the files in a folder and put some validations so that my code should not replace any previous temp or log files. So I thought to share a small snippet of Excel VBA code where I am trying to search all the files in a Folder ( and its subfolders too) and printing in an Excel Worksheet.

Private fileCounter As Integer
Private activeSht As Worksheet
'Display all the files in a folder. Searches all the sub folders.

'Prints Folder Names in Column A and and the file Names in Column B

Sub SearchFiles()
    Dim pth As String
    Dim fso As FileSystemObject
    Dim baseFolder As Folder
                    
    pth = "C:\Projects\" 'the base path which has to be searched for Files
    Set fso = New FileSystemObject
                    
    ''check if the folder actually exists or not
                    
    If (Not (fso.FolderExists(pth))) Then
        'the folder path is invalid. Exiting.
        MsgBox "Invalid Path"
        Exit Sub
    End If
    
    Set baseFolder = fso.GetFolder(pth)
    
    fileCounter = 1
    Set activeSht = ActiveSheet
    
    activeSht.Range("A1").Value = "Folder Name"
    activeSht.Range("B1").Value = "File Name"
    
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    PrintFileNames baseFolder
    
ErrHandler:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
    
    
Sub PrintFileNames(baseFolder As Folder)
    Dim folder_ As Folder
    Dim file_ As File
    
    For Each folder_ In baseFolder.SubFolders
        'call recursive function.
        PrintFileNames folder_
    Next folder_
    
    For Each file_ In baseFolder.Files
        'print files here
        activeSht.Range("A1").Offset(fileCounter, 0).Value = baseFolder.Path
        activeSht.Range("B1").Offset(fileCounter, 0).Value = file_.Name
        fileCounter = fileCounter + 1
    Next file_
End Sub
    

The above code loops through all the subfolders and the files in a given folder and prints the folder names in Column A and the file Names in Column B.

HTH,
Vikas

Write Custom Functions in Excel.

Hi,

We all know that we can write Formulas in Excel. for example, =Sum(A1:A10) to sum the values present in range from A1 to A10. The summation is easy. Right??? But what if we want to tweak our requirements.

Let's assume we have a requirement, that we need to sum only those values which are divisible by 2. I have assumed a very basic example, although we can write an Excel Built in for this requirement, but I want to show to achieve this through Custom Function.

For example, I want to sum range A1 to A10. I will write a custom Function in Excel VBA. Open VBA editor, add Module 1 and add a function like following :

Public Function SumEvenValues(rng As Range) As Double
    Dim sum As Double
    Dim cell_ As Range
    
    sum = 0
    
    For Each cell_ In rng.Cells
        If (IsNumeric(cell_.Value)) Then
            'the value is numeric. Check the mod
            If (cell_.Value Mod 2 = 0) Then
                sum = sum + cell_.Value
            End If
        End If
    Next cell_
    
    SumEvenValues = sum
    
End Function

In your excel workbook, in Cell b1, type this : =SumEvenValues(A1:A10)

You will see that all the values which are divisible by 2 are summed up and the result is displayed in Cell B1. I have taken a very basic example to show it's use, which can be easily achived in Excel, but we may encounter to include those requirements which we may not be able to achieve within Excel only. So in such a case, VBA is used to handle all those requirements which Excel cannot handle.

HTH,
Vikas