Friday, July 9, 2010

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

Thursday, July 1, 2010

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