Match Excel Column against a Standard Range

Replace Values of a Column when it Matches

If you want to match the names in column2 against the standard names in column 1 & replace by the standard names the following should help:

Sub Replace_TExt()


For i = 1 To ActiveSheet.Range("B:B").Cells.SpecialCells(xlCellTypeLastCell).Row

If Trim(ActiveSheet.Range("B" & i)) <> "" Then

ActiveSheet.Range("A:A").Replace What:=ActiveSheet.Range("B" & i), Replacement:=ActiveSheet.Range("B" & i).Value, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False

End If

Next i
End Sub

Dynamic Copy of Matching Excel Data

Copy specific data in cells from Master Sheet to Current Sheet

Most often we would have the entire data in Excel and would require data corresponding to the cell value taken from the master sheet and populated in the current one dynamically.

In the following example the master sheet is named as "DB" and contains all records with the primary key being the first column.

Function Snippet_For_Copy(sSearchString)

If Trim(sSearchString) = "" Then Exit Function

With Sheets("DB").Columns("A:A")
Set rFindCell = .Find(sSearchString, LookIn:=xlValues, LookAt:=xlWhole)
If Not rFindCell Is Nothing Then
Sheets("DB").Rows(rFindCell.Row).EntireRow.Copy _
Destination:=Range("A" & ActiveCell.Row)
End If
End With

End Function

If the user enters a data in the first column of the current sheet, the above function will check the data in the DB sheet and transfer entire row if a match is found

You can trigger the function using Worksheet_SelectionChange event

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If IsNumeric(Target) = False Then Exit Sub
If Trim(Target) = "" Then Exit Sub

Application.EnableEvents = False

Snippet_For_Copy Target.Value

Application.EnableEvents = True
End Sub

Add ToolTipText in CommandBar Controls

Display ToolTipText in CommandBar Controls

Sub Show_ToolTipText_In_Controls()


Dim oCB As CommandBar
Dim oCtl As CommandBarControl

On Error Resume Next

' Delete Existing Command Bar
CommandBars("MyProject").Delete

'Create New Command Bar
Set oCB = CommandBars.Add
oCB.Name = "MyProject"
oCB.AdaptiveMenu = True


Set oCtl = oCB.Controls.Add(Type:=msoControlButton)
oCtl.Caption = "Show Message Box"
oCtl.TooltipText = "This is a sample"
oCtl.OnAction = "Display_Msg_Box"
oCtl.SetFocus

' Show the Command Bar
oCB.Visible = True

' Place the CommandBar at the bottom of the screen
oCB.Position = msoBarBottom

End Sub

Sub Display_Msg_Box()

MsgBox "You have clicked me!!!"

End Sub

Add Combo Box to the command Bar

Add Combo Box to the command Bar

Sub Show_Combo_CommandBar()


Dim oCB As CommandBar
Dim oCtl As CommandBarComboBox

On Error Resume Next

'Delete Control From CommandBar
CommandBars("Sample Command Bar").Delete

Set oCB = CommandBars.Add
oCB.Name = "Sample Command Bar"
oCB.AdaptiveMenu = True

'Add Control to CommandBar
Set oCtl = oCB.Controls.Add(Type:=msoControlComboBox)
oCtl.Caption = "ComboSamp"

'Link Macro to CommandBar,
oCtl.OnAction = "Change_Header_Background"

'Add list Item to Combo Box Control
oCtl.AddItem "NoColor"
oCtl.AddItem "Blue"
oCtl.AddItem "Yellow"


' Show the Command Bar
oCB.Visible = True

' Place the CommandBar at the bottom of the screen
oCB.Position = msoBarBottom

End Sub

Sub Change_Header_Background()

' Acts based on the value in the Combo Box

Dim oCB As CommandBar
Dim oCtl As CommandBarComboBox

On Error Resume Next


Set oCB = CommandBars("Sample Command Bar")

Set oCtl = oCB.Controls("ComboSamp")

If oCtl.ListIndex <> -1 Then

Select Case oCtl.ListIndex

Case 1

ActiveSheet.Rows(1).Interior.ColorIndex = 0

Case 2

ActiveSheet.Rows(1).Interior.ColorIndex = 5

Case 3

ActiveSheet.Rows(1).Interior.ColorIndex = 36

Case Else

' Do nothing

End Select

End If


' Show the Command Bar
oCB.Visible = True

' Place the CommandBar at the bottom of the screen
oCB.Position = msoBarBottom


End Sub

Visual Basic Get Screen Area

Windows API Get Screen Area

Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long
Const SM_CXSCREEN As Long = 0
Const SM_CYSCREEN As Long = 1


Here is the VBA function using GetSystemMetrics to get the screen area

Sub Get_Screen_Metrics()

' Windows API Function to Get Screen Area

lx = GetSystemMetrics(SM_CXSCREEN)
ly = GetSystemMetrics(SM_CYSCREEN)

'--------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
'--------------------------------------------------------

MsgBox "The Screen Area is " & lx & " x " & ly & " pixels"

' Visual Basic Get Screen Area, Visual Basic Get Screen Height, Visual Basic Get Screen Width ,Windows API Get Screen Area, Windows API Get Screen Height, Windows API Get Screen Width
End Sub

Retrieve the file properties - VBA

Sub Get_WorkBook_Properties()

Dim oWB As Workbook

' Here is the program to retrieve the file properties.

Set oWB = ActiveWorkbook

'--------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
'--------------------------------------------------------

'Get the Title property
sTitle = oWB.BuiltinDocumentProperties("Title").Value

'Get the Subject property
sSubject = oWB.BuiltinDocumentProperties("Subject").Value

'Get the Author property
sAuthor = oWB.BuiltinDocumentProperties("Author").Value

'Get the Keywords property
sKeywords = oWB.BuiltinDocumentProperties("Keywords").Value

'Get the Comments property
sComments = oWB.BuiltinDocumentProperties("Comments").Value

'Get the Template property
sTemplate = oWB.BuiltinDocumentProperties("Template").Value

'Get the Last author property
sLastauthor = oWB.BuiltinDocumentProperties("Last author").Value

'Get the Revision number property
sRevisionnumber = oWB.BuiltinDocumentProperties("Revision number").Value

'Get the Application name property
sApplicationName = oWB.BuiltinDocumentProperties("Application name").Value

'Get the Last print date property
sLastprintdate = oWB.BuiltinDocumentProperties("Last print date").Value

'Get the Creation date property
sCreationdate = oWB.BuiltinDocumentProperties("Creation date").Value

'Get the Last save time property
sLastsavetime = oWB.BuiltinDocumentProperties("Last save time").Value

'Get the Total editing time property
sTotaleditingtime = oWB.BuiltinDocumentProperties("Total editing time").Value

'Get the Number of pages property
sNumberofpages = oWB.BuiltinDocumentProperties("Number of pages").Value

'Get the Number of words property
sNumberofwords = oWB.BuiltinDocumentProperties("Number of words").Value

'Get the Number of characters property
sNumberofcharacters = oWB.BuiltinDocumentProperties("Number of characters").Value

'Get the Security property
sSecurity = oWB.BuiltinDocumentProperties("Security").Value

'Get the Category property
sCategory = oWB.BuiltinDocumentProperties("Category").Value

'Get the Format property
sFormat = oWB.BuiltinDocumentProperties("Format").Value

'Get the Manager property
sManager = oWB.BuiltinDocumentProperties("Manager").Value

'Get the Company property
sCompany = oWB.BuiltinDocumentProperties("Company").Value

'Get the Number of bytes property
sNumberofbytes = oWB.BuiltinDocumentProperties("Number of bytes").Value

'Get the Number of lines property
sNumberoflines = oWB.BuiltinDocumentProperties("Number of lines").Value

'Get the Number of paragraphs property
sNumberofparagraphs = oWB.BuiltinDocumentProperties("Number of paragraphs").Value

'Get the Number of slides property
sNumberofslides = oWB.BuiltinDocumentProperties("Number of slides").Value

'Get the Number of notes property
sNumberofnotes = oWB.BuiltinDocumentProperties("Number of notes").Value

'Get the Number of hidden Slides property
sNumberofhiddenSlides = oWB.BuiltinDocumentProperties("Number of hidden Slides").Value

'Get the Number of multimedia clips property
sNumberofmultimediaclips = oWB.BuiltinDocumentProperties("Number of multimedia clips").Value

'Get the Hyperlink base property
sHyperlinkbase = oWB.BuiltinDocumentProperties("Hyperlink base").Value

'Get the Number of characters (with spaces) property
sNumberofcharacters = oWB.BuiltinDocumentProperties("Number of characters (with spaces)").Value

'keywords: VBA Update File Properties, Macro to Update File Properties

End Sub

Drag & DRop Files to Text Box

Show File Name in Text Box using Drag & Drop

Private Sub TextBox1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i1 As Integer '* Files Counter

On Error GoTo Err_Trap

If Data.GetFormat(vbCFFiles) = True Then
i1 = Data.Files.Count
If i1 = 1 Then
If InStr(1, LCase$(Data.Files(i1)), ".xls") Then
txtExcel.Text = Data.Files(i1)
End If
End If
End If

' ------------------------------------------
' Error Handling
' ------------------------------------------
Err_Trap:
If Err <> 0 Then
Debug.Assert Err = 0
Err.Clear
End If
End Sub

This will be used to show the file name in the Text Box if a file is dragged and dropped into it

Automaticaly Resize Text Boxes

Resizing Text Boxes

Sub Initialize_TextBox()

' To automatically resize the text box set the AutoSize to True. This will resize the text box as the user types text

TextBox1.AutoSize = True

' The sizing can be limited by providing the maximum length using MaxLength property

TextBox1.MaxLength = 20

' You can inform the user of resing with the Tooltip.

TextBox1.ControlTipText = "Maximum Length is 20"

End Sub

ControlTipText is the VBA variant for Visual Basic ToolTipText

Primitive File Handling Functions

Copying Files/ Deleting Files / Moving Files

Sub Moving_Files()

Dim oFS As FileSystemObject

' Copying Files
FileCopy "c:\temp\IamAStar.xls", "c:\temp\backup\IamAStar.xls"

' Deleting Files
Kill "c:\temp\IamAStar.xls"

' Using File System Object - You need to Include Microsoft Scripting Runtime in you references
Set oFS = New FileSystemObject

' Moving Files
oFS.MoveFile "c:\temp\D8C7I12.xls", "c:\temp\backup\D8C7I12.xls"

End Sub

Check Workbook Attributes

Get File Attributes - GetAttr

Sub Check_Workbook_Attributes()

Dim oXL As Excel.Application
Dim oWB As Workbook

Set oXL = Excel.Application

oXL.DisplayAlerts = False

' Check if the Workbook is Read-Only. If it is then close the workbbok

Set oWB = oXL.Workbooks.Open(Filename:="c:\MyBook.xls", ReadOnly:=False)

If oWB.ReadOnly = True Then
MsgBox "The Workbook is Read-Only!!", vbInformation
oWB.Close False
End If

oXL.DisplayAlerts = True

' Using the GetAttr Function, WE can check if the file is read-only
If (GetAttr("c:\MyBook.xls") And vbReadOnly) Then
MsgBox "The Workbook is Read-Only!!", vbInformation
End If

End Sub

The GetAttr function will work if the file has read-only attributes. If the file is locked and hence it is available as read only this will not be useful

Validate Dates

Validate Date between Ranges

Sub Feed_Check_Date_Function()

' Date is within the Valid Range
Check_Date "2007-05-01", "2007-05-10", "2007-05-01"

' Date is NOT within the Valid Range
Check_Date "2007-05-01", "2007-05-10", "2007-05-21"


End Sub

Function Check_Date(ByVal StartDate As Date, ByVal EndDate As Date, ByVal DateTobeChecked As Date)

If DateDiff("d", StartDate, DateTobeChecked) <> 0 Then
MsgBox "Enter a correct date!!!"
End If

End Function

Run Macro on Image Click

Tag Macro to an Image

Sub Run_Macro_On_ImageClick()

Dim sht As Worksheet
Dim shp As Shape

' Use OnAction Property to set the macro that needs to be run when the image is clicked

Set sht = ActiveSheet

Set shp = sht.Shapes(1)

shp.OnAction = "Macro1"

End Sub

Changing File Attributes

SetAttr Function - Modifying File Atrributes

Sub Changing_File_Attributes()

' Using the SetAttr Function, We can set the file as read-only or hidden etc

' Make the file Read-Only
SetAttr "c:\temp\Sample.txt", vbReadOnly

' Make the file Hidden
SetAttr "c:\temp\Sample.txt", vbHidden

' Please note that if you change one attribute, the existing attribute is overwritten. For making a file as both readonly and hidden use both attributes in the function
SetAttr "c:\temp\Sample.txt", vbHidden + vbReadOnly

' Remove all atributes - convert a read-only file to read-write file, unhide the file etc
SetAttr "c:\temp\Sample.txt", vbNormal

End Sub

Choose the Right Value

VBA - Choose Function

Sub Easy_To_Choose()

Dim iGroupCode As Integer
Dim sGroupName As String

iGroupCode = 1

If iGroupCode = 1 Then
sGroupName = "Blue"
ElseIf iGroupCode = 2 Then
sGroupName = "Green"
ElseIf iGroupCode = 3 Then
sGroupName = "Yellow"
ElseIf iGroupCode = 3 Then
sGroupName = "Red"
End If


Select Case iGroupCode
Case 1
sGroupName = "Blue"
Case 2
sGroupName = "Green"
Case 3
sGroupName = "Yellow"
Case 3
sGroupName = "Red"
End Select


' Choose Function does the same as that of Select Case or the If constructs
' But the Choose function returns a Null if index is less than 1 or greater than the number of choices listed.
iGroupCode = 2
sGroupName = Choose(iGroupCode, "Blue", "Green", "Yellow", "Red")

End Sub

You can store the values in the array and can pass that to the choose function

Flip Shapes

Rotate Images - Flip Images

Sub Flip_Shapes()

Dim sht As Worksheet
Dim shp As Shape

' Flip the Image - Turn the Image Upside Down

Set sht = ActiveSheet

Set shp = sht.Shapes(1)

shp.Flip msoFlipVertical

End Sub

Environmental Variables using VBA

Get OS Name / Get Windows Directory

Sub Environ_Vars()

' Get Environmental Variables using VBA

' Get the LOGON SERVER
sLOGONSERVER = Environ("LOGONSERVER")

' No of processors using VBA
sNUMBER_OF_PROCESSORS = Environ("NUMBER_OF_PROCESSORS")

' Get the Operating System using VBA
sOS = Environ("OS")

' Get the USER DOMAIN using VBA
sUSERDOMAIN = Environ("USERDOMAIN")

' Get the Windows Directory using VBA
swindir = Environ("windir")

End Sub

Format Images

Format Images - Change Size of Images

Sub Format_Image_In_Excel()

Dim sht As Worksheet
Dim shp As Shape

' Reduce the Height and Width of the Image by Half

For Each sht In Sheets

For Each shp In sht.Shapes

shp.Height = shp.Height / 2
shp.Width = shp.Width / 2
Next

Next sht

End Sub

Compare Files by Date

Function to Find the Latest File


Sub Exec_Get_Latest_File()

File1 = "c:\temp\Sample.txt"
File2 = "c:\temp\Sample1.txt"

MsgBox "The LatestFile is " & Get_Latest_File(File1, File2)

End Sub

Function Get_Latest_File(ByVal sFile1 As String, ByVal sFile2 As String) As String


Dim DateFile1 As Date
Dim DateFile2 As Date

DateFile1 = FileDateTime(sFile1)
DateFile2 = FileDateTime(sFile2)

If DateDiff("s", DateFile1, DateFile2) = 0 Then
Get_Latest_File = "Both Files are Modified at the same time"
ElseIf DateDiff("s", DateFile1, DateFile2) <>
Get_Latest_File = sFile1
Else
Get_Latest_File = sFile2
End If

End Function

Find Image Range - Excel

Format Images - Range of Image

Sub Find_Image_Range_In_Excel()

Dim sht As Worksheet
Dim shp As Shape

For Each sht In Sheets

For Each shp In sht.Shapes
MsgBox "Shape Extends from ( " _
& shp.TopLeftCell.Row & "," & shp.TopLeftCell.Column & ") to (" _
& shp.BottomRightCell.Row & "," & shp.BottomRightCell.Column & ")"
Next

Next sht

End Sub

Get the File Size

File Size - VBA Function

Sub Get_File_Size()

File1 = "c:\temp\Sample.txt"

MsgBox "The Size of the File is " & FileLen(File1) & " bytes"

End Sub

Removing Pictures from Spreadsheet

Delete Images from Spreadsheets

Sub Delete_Images_From_Excel()

Dim sht As Worksheet
Dim shp As Shape

For Each sht In Sheets

For Each shp In sht.Shapes
shp.Delete
Next

Next sht

End Sub

Filtering Array Elements

Filtering Array Elements

Most often there will be a neccesity to filter content from the Array. Filter Function comes as a blessing:

Sub Get_Filtered_Array()

Dim arOriginal(0 To 4) As String
Dim arFiltered() As String

arOriginal(0) = "Bob Woolmer"
arOriginal(1) = "Dean Jones"
arOriginal(2) = "Bob Richards"
arOriginal(3) = "Ravi Shastri"
arOriginal(4) = "Greg Chappel"

' Filtered Array will contain strings that contains Bob in it
arFiltered = Filter(arOriginal, "Bob")

' Filter - Returns a zero-based array containing subset of a string array based on a specified filter criteria.
End Sub

If no matches of Bob are found within arOriginal, Filter returns an empty array. An error occurs if arOriginal is Null or is not a one-dimensional array.

The array returned by the Filter function contains only enough elements to contain the number of matched items.

Visual Basic Command Line Arguments

Retrieve Command Line Arguments from a Microsoft Visual Basic or an executable program developed with Visual Basic from Command Line

Sub Command_Line_Call()

sCmdText = Trim$(Command$)

' You can give multiple parameters through command line with specific delimiters

arCmdData = Split(sCmdText, ",")
If arCmdData(0) = "PRG1" Then
Exec_PRG1 (arCmdData(1))
ElseIf arCmdData(0) = "PRG2" Then
Exec_PRG2 (arCmdData(1))
If arCmdData(0) = "PRG3" Then
Exec_PRG3 (arCmdData(1))
End If


End Sub

' Retrieve Command Line Arguments, Launch PRogram from command, Execute Visual Basic Program from Command Line

Get Computer Name

Get Computer Name / Get User Name

Environ$ can be used to retrieve information from an operating system environment variable

Sub Get_Environmental_Variable()

Dim sHostName As String
Dim sUserName As String

' Get Host Name / Get Computer Name

sHostName = Environ$("computername")

' Get Current User Name

sUserName = Environ$("username")


End Sub

In Dot Net it can be achieved by http://dotnetdud.blogspot.com/2007/06/get-computer-name-in-net.html

and

http://dotnetdud.blogspot.com/2007/06/aspnet-get-user-net-get-user.html

Improve Macro Performance

Increase Macro Speed

Sub Speed_Up_Performance()

Set_Performance_Options

' Use Early Binding Instead of late binding

' Do not use Variant if you can use Long, String data types

' If you want to loop through the documents/workbooks use For each
For Each Doc In Documents
' Do something
Next Doc

ReSet_Performance_Options

End Sub



Function Set_Performance_Options()

' If an updated cell value is necessary for the macro. Then either do not use this or used forced calculation using calculate method
Application.Calculation = xlCalculationManual

Application.ScreenUpdating = False

End Function

Function ReSet_Performance_Options()

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

End Function

' ScreenUpdating, Calculation, Early Binding, late binding, Speedup VBA Performance, Optimize VBA Code, Visual Basic Code Optimization

Generic Function to Check if Application is Running

Check if Instance of Application is Running


' Change the sApp Variable to check the Application you needed



Sub Check_If_Application_Is_Open()

'Check if Instance of MS Word is Running in the machine

sApp = "Word.Application"
If IsAppRunning(sApp) = True Then
MsgBox "Application is Running"
Else
MsgBox "Application is NOT Running. Let me create my own"
' Create a new instance
Set oApp = CreateObject(, sApp)
End If


End Sub

' Generalized Function to Check if an Instance of Application is running in the machine
Function IsAppRunning(ByVal sAppName) As Boolean
Dim oApp As Object
On Error Resume Next
Set oApp = GetObject(, sAppName)
If Not oApp Is Nothing Then
Set oApp = Nothing
IsAppRunning = True
End If
End Function

' Generic Function to Check if Application is Running, Visual Basic GetObject, VBA GetObject, VB6 GetObject

VBA Function to Check File Existence

This Visual Basic Function can be used to check if a file exists under a specific directory

Sub Check_If_File_Exists()

' To Check if a file is present, give the file name and omit the second argument
sFile = "c:\Temp\Test.txt"
If File_Exists(sFile) = True Then
MsgBox sFile & " exist"
Else
MsgBox sFile & " does not exist"
End If

' To Check if a directory is present, give the directory name and make the second argument = True
sDir = "d:\VBADudExamples\Code"
If File_Exists(sDir, True) = True Then
MsgBox "Directory " & sDir & " exist"
Else
MsgBox "Directory " & sDir & " does not exist"
End If


End Sub
' Keywords : Check Directory Existence, VBA Dir Function, Visual Basic Dir Function, Dir$ Function Example, VB File Exists, VBA Check File Availability


Private Function File_Exists(ByVal sPathName As String, Optional Directory As Boolean) As Boolean

'Returns True if the passed sPathName exist
'Otherwise returns False
On Error Resume Next
If sPathName <> "" Then

If IsMissing(Directory) Or Directory = False Then

File_Exists = (Dir$(sPathName) <> "")
Else

File_Exists = (Dir$(sPathName, vbDirectory) <> "")
End If

End If
End Function

BlogRankings.com

All-Blogs.net directory

Visual Basic Function to Get Temporary Folder

Windows API Function to Get Temporary Folder

Private Declare Function GetTempPath Lib "kernel32" Alias _
"GetTempPathA" (ByVal nBufferLength As Long, ByVal _
lpBuffer As String) As Long

Const MAX_PATH = 260

' This function uses Windows API GetTempPath to get the temporary folder

Sub Get_Temporary_Folder()

sTempFolder = GetTmpPath

End Sub

' Keywords: Get Temporary Folder, Temporary Folder Visual Basic Code, VB Function Get Temp Folder, VBA Temporary Folder, VB6 Temporary Folder, GetTempPath, Windows API Functions


Private Function GetTmpPath()

Dim sFolder As String ' Name of the folder
Dim lRet As Long ' Return Value

sFolder = String(MAX_PATH, 0)
lRet = GetTempPath(MAX_PATH, sFolder)

If lRet <> 0 Then
GetTmpPath = Left(sFolder, InStr(sFolder, _
Chr(0)) - 1)
Else
GetTmpPath = vbNullString
End If

End Function

This function can be used to identify the Temporary folders for Windows XP kind of OS, where each login will have its own temp folder

VBA Email Automation / VBA Mail Automation

VBA Email Automation / VBA Mail Automation

Sub Send_Mail_From_Excel()


' This is an automatic mail program. It takes the mail Id's from activeworkbook and uses outlook object to send mail
' The format of the workbook should be as follows
' 1. Data Should start from Row 2 - Sheet 1
' 2. Salutation in Col 1 -e.g., Mr, Ms, Dr etc
' 3. Name in Col 2 -e.g., Sheetal
' 4. Email in Col 4 -e.g., sheetal@vbadud.com
' Program will loop through the entire sheet and send mails to all


Dim oXlWkBk As Excel.Workbook ' Excel Work Book Object

Dim oOLApp As Outlook.Application
Dim oOLMail As MailItem

Dim lRow As Long
Dim olMailItem

Dim sMailID As String
Dim sSalutation As String
Dim sName As String
Dim sDetails As String
Dim sSubject As String
On Error GoTo Err_Trap


Set oXlWkBk = ActiveWorkbook

If oXlWkBk.Sheets(1).Cells.SpecialCells(xlCellTypeLastCell).Row < oolapp =" New" lrow =" 2" oolmail =" oOLApp.CreateItem(olMailItem)" ssalutation =" oXlWkBk.Sheets(1).Cells(lRow," sname =" oXlWkBk.Sheets(1).Cells(lRow," sdetails = "Hi"> 0 And LenB(Trim$(sSalutation)) <> 0) Then
sDetails = sSalutation & " " & sName
ElseIf LenB(Trim$(sName)) <> 0 Then
sDetails = sName
Else
sDetails = "Hi"
End If
sDetails = sDetails & vbNewLine & vbNewLine

sMailID = Trim$(oXlWkBk.Sheets(1).Cells(lRow, 3).Value)

' --- Validate EMail ID
If InStr(1, sMailID, "@") = 0 Then
GoTo TakeNextRow
End If

' Create Mail
With oOLMail
.To = sMailID
.Subject = sSubject
.Body = sDetails & "This is a test mail from VBA Tips & Tricks (http://vbadud.blogspot.com/)"
End With

oOLMail.Send

TakeNextRow:
Next lRow

oXlWkBk.Close (False)

'--------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
'--------------------------------------------------------


Destroy_Objects:
'Destroy Objects
If Not oOLApp Is Nothing Then Set oOLApp = Nothing


Err_Trap:
' Error Handling
If Err <> 0 Then
MsgBox Err.Description, vbInformation, "VBADUD AutoMail"
Err.Clear
GoTo Destroy_Objects
End If

'------------------------------------------------------------------------------------
' Disclaimer: VBA Tips & Tricks (http://vbadud.blogspot.com) publishes this content
' for the intention of sharing technical knowledge. Any misuse of this program (e.g., spamming)
' will not be our responsibility.
'------------------------------------------------------------------------------------


End Sub


'Keywords: 'Keywords: Automate Email, VBA Email, Send Email from Excel, VBA Mail automation, Mail Automation, Outlook VBA, Automate Outlook, Send Mail from Outlook, Link Excel with Outlook,Microsoft Outlook Mail Automation, Excel VBA Mail, MAPI, Send Multiple eMails





If you want to try the same using Lotus Notes refer http://vbadud.blogspot.com/2007/10/automate-lotus-notes-email-using-visual.html

SaveAs Dialog - Controlled Save

SaveAs Dialog - Controlled Save



Sub Save_File_Dialog()

Dim sFName

' Can be used as Excel SaveAs Dialog

'----------------------------
' Coded for http://vbadud.blogspot.com
'----------------------------


sFName = Application.GetSaveAsFilename
If sFName = False Then
MsgBox "Enter a File Name Please!!!"
End If

' Display Default FileName in the SaveAs Dialog/Save Dialog Box
sFName = Application.GetSaveAsFilename("VBADud_Example.xls")

' Force File Type during Save
sFName = Application.GetSaveAsFilename("VBADud_Example.xls", "Excel files (*.xls), *.xls")


End Sub

This method displays the standard Save As dialog box and gets a file name from the user without actually saving any files

This does not save the file...


See also :

Excel VBA - 1004 -- The file could not be accessed

Save and Reopen all Workbooks (Excel VBA)

Save copy of the workbook

SaveAs Dialog - Controlled Save

Save RTF document as word

Open Excel Files - Open Dialog - GetOpenFilename Method

Open Excel Files - Open Dialog - GetOpenFilename Method


The GetOpenFilename Method is a cousin to the CommonDialog. Some of the CommonDialog's tasks can he done with this method



GetOpenFilename Method (Displays the standard Open dialog box and gets a file name from the user without actually opening any files.)


Sub Open_Excel_File_Thru_VBA()

'----------------------------
' Coded for http://vbadud.blogspot.com
'----------------------------

Dim arTemp() As Variant

Dim lRet

On Error GoTo Err_Clr

'Default method Uses Open Dialog To Show the Files
lRet = Application.GetOpenFilename

'Select Only Excel Files - One File at A Time
lRet = Application.GetOpenFilename("Excel files (*.xls), *.xls")
If lRet = False Then
MsgBox "Select a File Please!!!"
End If

'Select Multiple Files - Get Multiple Files as Input
' An array can be used to get the multiple excel files selected by user
arTemp = Application.GetOpenFilename(FileFilter:="Excel files (*.xls), *.xls", MultiSelect:=True)
If UBound(arTemp) = 0 Then
MsgBox "Select a File Please!!!"
End If


Err_Clr:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End Sub



Excel VBA, GetOpenFilename Method, Show Dialog, , Show Open Dialog Box

Browse a Folder / Select a Folder Thru Shell

Browse a Folder / Select a Folder Thru Shell

Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

'API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Here let us use the above shell functions to open the browse directory dialog

Sub Show_BrowseDirectory_Dialog()

' BrowseForFolder
' SHBrowseForFolder API Function Example

Dim dirInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer

' Set Default Root folder = Desktop
dirInfo.pidlRoot = 0&

dirInfo.lpszTitle = "Browse directory!"

' Type of directory
dirInfo.ulFlags = &H1

' Show the Browse Dialog
x = SHBrowseForFolder(dirInfo)

' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
MsgBox "You have selected :=" & Left(path, pos - 1)
Else
MsgBox "Browse a Directory..."
Show_BrowseDirectory_Dialog
End If

End Sub

SHBrowseForFolder Function displays a dialog box enabling the user to select a Shell folder

Add Controls To Tools Menu

Creating Custom Office Menus and Toolbars

Sub Call_Add_Control_To_ToolsMenu()

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------
Add_Control_To_ToolsMenu "Sample", "Donot_Fire_Events"

End Sub

you need to have a sub Donot_Fire_Events to test this

Function Add_Control_To_ToolsMenu(ByVal sControlName As String, ByVal sMacroName As String)

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

On Error GoTo DisplayErr

Dim ctlMenu As CommandBarControl
Dim ctlCommand As CommandBarControl

Set ctlMenu = Application.CommandBars.FindControl(ID:=30007)

If ctlMenu Is Nothing Then Exit Function

Set ctlCommand = ctlMenu.Controls.Add
ctlCommand.Caption = sControlName
ctlCommand.OnAction = sMacroName

DisplayErr:
If Err <> 0 Then
MsgBox Err.Description
Err.Clear
End If


Creating Custom Office Menus and Toolbars, Programming Microsoft Office Command Bars, CommandBars Property, Creating an Excel Add-in, Disable command bars and controls, Change the availability for the CommandBars using VBA, Delete/ hide a custom command bar

Add a new menu item to the Tools menu, Adding Menu Items, Add Command to Tools menu, Dynamic Addition of command to tools menu. Adding Command Button to Tools, Adding to Tools menu


End Function

Deleting Custom Office Menus and Toolbars

Deleting Custom Office Menus and Toolbars

Function delete_Control_from_ToolsMenu(ByVal sControlName As String)

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

On Error GoTo DisplayErr

Dim ctlMenu As CommandBarControl
Dim ctlCommand As CommandBarControl

Set ctlMenu = Application.CommandBars.FindControl(ID:=30007)

If ctlMenu Is Nothing Then Exit Function

Set ctlCommand = ctlMenu.Controls(sControlName)

If Not ctlCommand Is Nothing Then ctlCommand.Delete

DisplayErr:
If Err <> 0 Then
MsgBox Err.Description
Err.Clear
End If

End Function

Creating Custom Office Menus and Toolbars, Programming Microsoft Office Command Bars, CommandBars Property, Creating an Excel Add-in, Disable command bars and controls, Change the availability for the CommandBars using VBA, Delete/ hide a custom command bar

enable popup menu

Sub Enable_Right_Click()

You can use the following function to enable mouse click - Right Click

This will enable popup menu



' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

' This will enable mouse right click on worksheets

Application.CommandBars("Cell").Enabled = True

End Sub

Disable Right Click

You can use the following function to disable mouse click. Right Click

This will disable popup menu

Sub Disable_Right_Click()

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

' This will disable mouse right click on worksheets

Application.CommandBars("Cell").Enabled = False

End Sub


D

Add Control To PopupMenu

Add Control To PopupMenu

Use this function to add the control to the popup menu

Function Add_Control_To_PopupMenu(ByVal sControlName As String, ByVal sMacroName As String)

On Error GoTo DisplayErr

Dim ctlCB As CommandBar
Dim ctlMenu As CommandBarControl
Dim ctlCommand As CommandBarControl

Set ctlCB = Application.CommandBars("Cell")

If ctlCB Is Nothing Then Exit Function

Set ctlCommand = ctlCB.Controls.Add
ctlCommand.Caption = sControlName
ctlCommand.OnAction = sMacroName

DisplayErr:
If Err <> 0 Then
MsgBox Err.Description
Err.Clear
End If


'Creating Custom Office Menus and Toolbars, Programming Microsoft Office Command Bars, CommandBars Property, Creating an Excel Add-in, Disable command bars and controls, Change the availability for the CommandBars using VBA, Delete/ hide a custom command bar

End Function
Sub Call_Add_Control_To_PopupMenu()

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

Add_Control_To_PopupMenu "Sample", "Donot_Fire_Events"

End Sub

Add a new menu item to the Popup menu, Adding Menu Items, Add Command to Popup menu, , Dynamic Addition of command to Popup menu. Adding Command Button to Popup, Adding to Popup menu

Delete Control From PopupMenu

Delete Control From PopupMenu (Right Click Menu)

Function Delete_Control_From_PopupMenu(ByVal sControlName As String, ByVal sMacroName As String)

On Error GoTo DisplayErr

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

Dim ctlCB As CommandBar
Dim ctlCommand As CommandBarControl

Set ctlCB = Application.CommandBars("Cell")

If ctlCB Is Nothing Then Exit Function

Set ctlCommand = ctlCB.Controls(sControlName)

If Not ctlCommand Is Nothing Then ctlCommand.Delete

DisplayErr:
If Err <> 0 Then
MsgBox Err.Description
Err.Clear
Resume Next
End If


'Creating Custom Office Menus and Toolbars, Programming Microsoft Office Command Bars, CommandBars Property, Creating an Excel Add-in, Disable command bars and controls, Change the availability for the CommandBars using VBA, Delete/ hide a custom command bar

End Function
Sub Call_Delete_Control_From_PopupMenu()

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

Delete_Control_From_PopupMenu "Sample", "Donot_Fire_Events"

End Sub

Add a new menu item to the Tools menu, Adding Menu Items, Add Command to Tools menu, , Dynamic Addition of command to tools menu. Adding Command Button to Tools, Adding to Tools menu

Using VBA's IsError Function

' Using VBA's IsError Function
For Each c1 In ActiveSheet.UsedRange

If IsError(c1) Then
' Coded By Shasur

MsgBox "Error in " & c1.Address

End If
Next

End Sub

Excel Dialog Sheets

Here you have Kathy (and all programmers who need to work on the legacy Excel VBA code). Dialog sheets

Sub The_Good_Old_Dialog_Boxes()

ActiveDialog.Focus = "EditBox1"

Application.ThisWorkbook.DialogSheets("Dialog1").Buttons("cmdOK").Enabled = False

ActiveDialog.EditBoxes("EditBox1").Text = vbNullString

End Sub

Insert Dialog Sheet

' Ha ha .. If you haven't used dialog sheets before and wanted to have a feel on it, here we go

Sub Insert_Dialog_Sheet()

ActiveWorkbook.Sheets.Add Type:=xlDialogSheet

End Sub

You will find the sheet getting transformed to a Grid and a userform like control - the dialog sheet. The dialog sheets have been replaced by UserForms in Excel 97

Case in-sensitive comparison

Option Compare Text

If you do not worry about the case in comparisons, then use the Option Compare Text for string comparisons based on a case-insensitive text sort order determined by system's locale
Warning: This cannot be set for procedure level. When set, this will be for the entire module

Sub Option_Compare_Statement_Example()


Dim sStr1 As String ' String 1
Dim sStr2 As String ' String 2

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

sStr1 = "MixedCase"
sStr2 = "mixedcase"


If InStr(1, sStr1, sStr2) Then
MsgBox "Matching!!!"
End If

' ---------------------------------------------------------------
'
' ---------------------------------------------------------------

End Sub

Option Compare Text

If you do not worry about the case in comparisons, then use the Option Compare Text for string comparisons based on a case-insensitive text sort order determined by system's locale
Warning: This cannot be set for procedure level. When set, this will be for the entire module

Sub Option_Compare_Statement_Example()


Dim sStr1 As String ' String 1
Dim sStr2 As String ' String 2

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

sStr1 = "MixedCase"
sStr2 = "mixedcase"


If InStr(1, sStr1, sStr2) Then
MsgBox "Matching!!!"
End If

' ---------------------------------------------------------------
'
' ---------------------------------------------------------------

End Sub

Delete Temporary Files

Sub Delete_Temp_Files_Primitive()

Dim sFileType As String ' Declare the Type of File
Dim sTempDir As String ' Temporary Directory

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

On Error Resume Next

sFileType = "*.tmp"
sTempDir = "c:\windows\Temp\" ' There might be mutiple temp directories (one for each profile) in Windows XP. Modify the code accordingly

Kill sTempDir & sFileType

' ---------------------------------------------------------------
' Delete Temporary Files, Excel VBA, Kill Statement
' ---------------------------------------------------------------

End Sub

Aligning Text Output in Variables

Formatting Report - Formatting Text Files

Sub Aligning_Text_In_Variables()

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

' Aligment of Text in Reports is a pain.. that too if the report is a flat file

' Here are a couple of ways to align

Dim sCharBuff As String
Dim sName As String
Dim sAge As String
Dim sAdd As String
Dim sPrint As String

' Left Alignment
' Example
' Name :
' Age :
' Address :


sCharBuff = "123456789123456789" ' Just for length
sName = "Name"
sAge = "Age"
sAdd = "Address"

sPrint = sCharBuff
LSet sPrint = sName
Debug.Print sPrint & ":"

sPrint = sCharBuff
LSet sPrint = sAge
Debug.Print sPrint & ":"

sPrint = sCharBuff
LSet sPrint = sAdd
Debug.Print sPrint & ":"

' Right Alignment
' Example
' Name:
' Age:
' Address:


sCharBuff = "123456789123456789" ' Just for length
sName = "Name"
sAge = "Age"
sAdd = "Address"

sPrint = sCharBuff
RSet sPrint = sName
Debug.Print sPrint & ":"

sPrint = sCharBuff
RSet sPrint = sAge
Debug.Print sPrint & ":"

sPrint = sCharBuff
RSet sPrint = sAdd
Debug.Print sPrint & ":"


' ---------------------------------------------------------------
' Aligning Text Output in Variables
' ---------------------------------------------------------------


End Sub

Moving Log Files

Sub Naming_Files()

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------
' Programmers use log files to updated the status of the process
' Depending on the output the files are renamed or moved
' Here is a simple function to move and rename files


Name "d:\VBADudExamples\InProgress\Process.log" As "d:\VBADudExamples\Completed\Completed.log"


' ---------------------------------------------------------------
' Moving Log Files, Creating Log Files, Excel VBA, Name Statement
' ---------------------------------------------------------------


End Sub

Run-time Error 55!!! File already open

Run-time Error 55 File already open. This is one of the common error in file handling. It is difficult to avoid if you handle multiple files and use direct file numbers


Sub TextFile_Write_Error()

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------
'


' ------------------------
' Code with Errors
' ------------------------
Open "d:\VBADudExamples\TextFile1.txt" For Output As #1 ' Open file for output.

Print #1, "TextFile1"

Open "d:\VBADudExamples\TextFile2.txt" For Output As #1 ' Open file for output.

Close #1 ' Close file.

Close #1 ' Close file.

' ------------------------
' Workaround for the Errors
' ------------------------
' Use FreeFile to get a file number that is not used

iF1 = FreeFile ' Returns an Integer representing the next file number available for use by the Open statement.
Open "d:\VBADudExamples\TextFile1.txt" For Output As #iF1 ' Open file for output.

Print #iF1, "TextFile1"

iF2 = FreeFile
Open "d:\VBADudExamples\TextFile2.txt" For Output As #iF2 ' Open file for output.

Close #iF2 ' Close file.

Close #iF1 ' Close file.


' ------------------------------------------------
' Excel VBA, Run-time Error 55, File already open
' ------------------------------------------------


End Sub

Spacing in Text Files

Formatting Report , Formatting Text Files, Aligning Text File

For a Neatly Spaced Text File:

Sub EquiSpaced_TextFile()

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

Dim iMaxLength As Integer

iMaxLength = 20

Open "d:\VBADudExamples\TabbedFile.txt" For Output As #1 ' Open file for output.

Print #1, "Name "; Tab(iMaxLength); "Santhosh Prabhakaran"
Print #1, "Place "; Tab(iMaxLength); "Madras"
Print #1, "Designation "; Tab(iMaxLength); "Admin Manager"

Close #1 ' Close file.

' Excel VBA, Write to Text File, Neatly Spaced Text File


End Sub

Get Variable Type

To know the data type of the variable:

Function Get_Variable_Type(myVar)

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

If VarType(myVar) = vbNull Then
MsgBox "Null (no valid data) "
ElseIf VarType(myVar) = vbInteger Then
MsgBox "Integer "
ElseIf VarType(myVar) = vbLong Then
MsgBox "Long integer "
ElseIf VarType(myVar) = vbSingle Then
MsgBox "Single-precision floating-point number "
ElseIf VarType(myVar) = vbDouble Then
MsgBox "Double-precision floating-point number "
ElseIf VarType(myVar) = vbCurrency Then
MsgBox "Currency value "
ElseIf VarType(myVar) = vbDate Then
MsgBox "Date value "
ElseIf VarType(myVar) = vbString Then
MsgBox "String "
ElseIf VarType(myVar) = vbObject Then
MsgBox "Object "
ElseIf VarType(myVar) = vbError Then
MsgBox "Error value "
ElseIf VarType(myVar) = vbBoolean Then
MsgBox "Boolean value "
ElseIf VarType(myVar) = vbVariant Then
MsgBox "Variant (used only with arrays of variants) "
ElseIf VarType(myVar) = vbDataObject Then
MsgBox "A data access object "
ElseIf VarType(myVar) = vbDecimal Then
MsgBox "Decimal value "
ElseIf VarType(myVar) = vbByte Then
MsgBox "Byte value "
ElseIf VarType(myVar) = vbUserDefinedType Then
MsgBox "Variants that contain user-defined types "
ElseIf VarType(myVar) = vbArray Then
MsgBox "Array "
Else
MsgBox VarType(myVar)
End If

' Excel VBA, Visual Basic, Get Variable Type, VarType


End Function

Optional Parameter Example

Function Optional_Param_Example(Optional ByVal vOptionalText1 As Variant, Optional ByVal sOptionalText2 As String)

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

If IsMissing(vOptionalText1) Then
MsgBox "Optional Parameter 1 Missing.."
Else
MsgBox "Optional Parameter 1 Present.."
End If

IsMissing does not work on simple data types (such as Integer or Double) because, unlike Variants, they don't have a provision for a "missing" flag bit.
sOptionalText2 is not reported missing if it is not supplied

If IsMissing(sOptionalText2) Then
MsgBox "Optional Parameter 2 Missing.."
Else
MsgBox "Optional Parameter 2 Present.."
End If

' IsMissing Function, Optional Parameters, IsMissing Doesn't Work

End Function

Show Help From VB

If you have compiled help file (.chm) you can show it using the following

Function Call_Application_Help_MyApp(Optional ByVal vHelpText As Variant)

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

Application.Help "c:\Sample.chm"

' HTML Help, Using Help, Link Application Help with Program
End Function

Technorati Profile

Showing Excel Help

Showing Excel Help

Use this function to show the help; based on helpID

Function Call_Application_Help_Excel(Optional ByVal vHelpText As Variant)

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

If Val(Application.Version) = 10 Then
Application.Help "XLMAIN10.CHM", vHelpText
Else
Application.Help "XLMAIN9.CHM", vHelpText
End If

' Excel VBA, Using Help, Link Application Help with Program
End Function

Save RTF document as word

Convert RTF document To Word

Sub Open_n_Save()

sFile = Dir$("C:\ReFormated\*.rtf", vbNormal)
Do Until Len(sFile) = 0
Documents.Open "C:\ReFormated\" & sFile
ActiveDocument.SaveAs "C:\ReFormated\" & sFile & ".doc", wdFormatDocument
ActiveDocument.Close False
sFile = Dir$
Loop


End Sub

See also :

Excel VBA - 1004 -- The file could not be accessed

Save and Reopen all Workbooks (Excel VBA)

Save copy of the workbook

SaveAs Dialog - Controlled Save

Using Excel Functions in VBA

Excel has several useful functions, which can be implemented in VBA code using the Evaluate Method

Evaluate Method converts a Microsoft Excel name to an object or a value


For example , the following method adds the values of the cells A1 to A6.

Sub Evaluate_Usage()

Dim lSum As Long

lSum = Evaluate("=SUM(A1:A6)")

End Sub

USe of evaluate has reduced a roundabout way of looping thru the cells and summing it up.

What next.. use the sum if, count if functions and evaluate!!!

Display text in a multiple lines

To display several lines of text in a text box, using vbcrlf at the end of each line

Set MultiLine property to True either in the Properties window

alternatively this can be set in runtime like:

TextBox1.MultiLine = True

Display Time Dynamically

Display Time Dynamically in Form using Time/Now Function

Add a Timer Control to your form and set the timer interval.

In the Timer event for that timer set (refresh) the time

Private Sub Timer1_Timer()

Label1.Caption = Date & " " & Time

End Sub

In the Form Load Event Intialize the interval
Private Sub Form_Load()
Timer1.Interval = 1000
End Sub

Execute Excel Macro in All Files

You can use the following code to execute the macro in all Excel (.xls) files under a given folder. You can tweek a bit if necessary

Sub Exec_Macro_For_All()

Dim sPath As String
Dim sFile As String
Dim sDir As String
Dim oWB As Workbook
Dim i1 As Long
Dim iMax As Long

On Error GoTo Err_Clk

sPath = "" ' Your Path
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"

sDir = Dir$(sPath & "*.xls", vbNormal)
Do Until LenB(sDir) = 0
Set oWB = Workbooks.Open(sPath & sDir)
Exec_MyMacro() ' Your MAcro here
oWB.Save
oWB.Close False
sDir = Dir$
Loop

Err_Clk:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End Sub

Cheers
Shasur

Get User Name using Split Function

This is a simple way of using the split function to get the user name

Sub Get_EMail_User_Name()

sEmail = "joe@gmail.com"

arTemp = Split(sEmail, "@")

sDomain = arTemp(LBound(arTemp))
End Sub

Cheers
Shasur

Get Domain Name from eMail (Split Function)

This is a simple way of using the split function to get the domain name

Sub Get_Domain()

sEmail = "joe@gmail.com"

arTemp = Split(sEmail, "@")

sDomain = arTemp(UBound(arTemp))
End Sub

Cheers
Shasur

Disabling Excel events

In some cases, we would have written some code in Worksheet_SelectionChange, Workbook_SheetActivate, etc and do not want them to be fired. This will be used if you have some event to be fired when the user enters a value, but do not want them if the value is from VBA code etc. In that case switch off the Application.EnableEvents and turnit on after the

process.

Sub Donot_Fire_Events()

Application.EnableEvents = False

' Coding to skip these events

Application.EnableEvents = True

End Sub

Excel Not Calculating Formula

If Excel does not re-calculate the formula. That is, if the cell is not refreshed inspite of newvalues, the Calculation might not be set as automatic. To set the calculation as automatic, use the following:

Sub Switch_On_XL_Calculation()

Application.Calculation = xlCalculationAutomatic

End Sub

Transferring array to Excel range

Is there any method to transfer the contents of the array to an Excel Range.. Most often programmers used to loop thru the array and put it to the Excel (of course with another loop). Here is a simple code that will transfer the array contents to Excel. Many thanks to Sharmila Purushotaman for this thoughful article

Sub Sheet_Fill_Array()
Dim myarray As Variant
myarray = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
Range("A1:A10").Select
Range("A1:A10").Value = Application.WorksheetFunction.Transpose(myarray)
End Sub

' Keywords : ARRAY to Excel, Transferring array to range

Character to ASCII

This function will print the ASCII values for corresponding characters in the first and second column respectively

Sub Convert2_Asc_Values()

For i1 = 1 To 256

Cells(i1 + 1, 3).Value = Asc(Cells(i1 + 1, 2).Value)

Next i1
End Sub



AddMe - Search Engine Optimization

ASCII to Character

There have been many times that we want to know the ASCII values. Ths function will print the character codes for the ASCII values in the first and second column respectively

Sub Print_Asc_Values()
For i1 = 1 To 255
Cells(i1 + 1, 1) = i1 Cells(i1 + 1, 2) = Chr(i1) Next i1
End Sub

Cheers
Shasur

Shared Name For the Drive

QueryDosDeviceW API Function can be used to get the device name.

To get the Shared Name of the drive, use the following function:

Public Function ConvertDrive2ServerName(ByVal sFullPath As String) As String


' --- Replaces the DriveName with ShareName in a given string

Dim FSO As FileSystemObject

Dim sDrive As String

Dim drvName As Drive

Dim sShare As String



On Error GoTo Err_Trap



Set FSO = New FileSystemObject



sDrive = FSO.GetDriveName(sFullPath)

Set drvName = FSO.GetDrive(sDrive)

sShare = drvName.ShareName



If LenB(sShare) <> 0 Then

ConvertDrive2ServerName = Replace(sFullPath, sDrive, sShare, 1, 1, vbTextCompare)

Else

ConvertDrive2ServerName = sFullPath

End If

If Not FSO Is Nothing Then Set FSO = Nothing



' ---------------------------------------

' Error Handling

' ---------------------------------------

Err_Trap:

If Err <> 0 Then

Err.Clear

Resume Next

End If

End Function

The function returns the DriveName with ShareName in a given string. It is advisable for programmers to store all the file locations using Sharename instead of DriveName

Cheers

Shasur

Get the Device Name (API Function)

Declare the API Function

Private Declare Function QueryDosDeviceW Lib "kernel32.dll" ( _ ByVal lpDeviceName As Long, _ ByVal lpTargetPath As Long, _ ByVal ucchMax As Long _ ) As Long Const MAX_PATH = 260

The following function accepts the drive as string and returns the device name

Public Function GetNtDeviceNameForDrive( _

ByVal sDrive As String) As String



Dim bDrive() As Byte

Dim bResult() As Byte

Dim lR As Long

Dim sDeviceName As String



If Right(sDrive, 1) = "\" Then

If Len(sDrive) > 1 Then

sDrive = Left(sDrive, Len(sDrive) - 1)

End If

End If

bDrive = sDrive



ReDim Preserve bDrive(0 To UBound(bDrive) + 2) As Byte

ReDim bResult(0 To MAX_PATH * 2 + 1) As Byte



lR = QueryDosDeviceW(VarPtr(bDrive(0)), VarPtr(bResult(0)), MAX_PATH)

If (lR > 2) Then

sDeviceName = bResult

sDeviceName = Left(sDeviceName, lR - 2)

GetNtDeviceNameForDrive = sDeviceName

End If



End Function


For example

Sub Trial()

MsgBox GetNtDeviceNameForDrive("c:")

End Sub

Dir Function in VBA (Visual Basic)

Dir or Dir$ Function can be used in Microsoft Visual Basic (Applications) to get the list of directories or files

sDir = Dir$(sPath & "*.xls", vbNormal)

Do Until LenB(sDir) = 0

Set oWB = Workbooks.Open(sPath & sDir)

‘ Do some stuff

oWB.close

sDir = Dir$

Loop

The above will open all Excel Workbooks under a particular directory.

Excel VBA - How to Know if the Cell Has Formula

To get the cell that contains formula couple of useful properties are available in Excel VBA

1. HasFormula
2. SpecialCells(xlCellTypeFormulas)

HasFormula will give True or False depending on the availabiliy of formulas

whereas

SpecialCells(xlCellTypeFormulas) can be used to select all the cells that contain formula

cells.SpecialCells(xlCellTypeFormulas).Select

or Set rng = cells.SpecialCells(xlCellTypeFormulas)

For each Cll in Rng

' Each cell containing formula

Next


Cheers
Shasur

Excel VBA InputBox

Excel VBA InputBox

InputBox method in Excel is more useful than the conventional inputBox functions when you require the user to select some range.

It is used as Application.InputBox

The Application.InputBox method differs from the usual InputBox function in that it allows selective validation of the user's input, and it can be used with Microsoft Excel objects, error values, and also formulas.

Application.InputBox calls the InputBox method; InputBox with no object qualifier calls the InputBox function.

MyRange = Application.InputBox("Select the Range?","My Application")

Homerweb Search

MSFlexGrid datasource - Object variable not defined

When you try to use MSFlexGrid.datasource the error 'Object variable not defined; pops up.

Try using the combination of Heirarchial FlexGrid and ADO Data Control


Adodc1.RecordSource = "Select * From Table"

and

Set MSHFlexGrid1.DataSource = Adodc1

Now the FlexGrid will be populated with the data from the ADO Data Control. This is more useful as this can be modified at run-time.



Cheers
Shasur

Category: MSFlexGrid.datasource error

Faster Program Execution - Microsoft

Faster Program Execution is the dream of every developer. Here are some few tips for that. This is tested for Microsoft Visual Basic programs

Replace all Trim(), Left(), Right(), Mid() etc with Trim$(), Left$(), Right$(), Mid$() . These are string functions which will increase the speed

Also

If you are comparing if a string is empty

use

Len(Trim("STring")) = 0

rather than

Trim("STring") = ""

Even better would be

LenB(Trim$("STring")) = 0

as LenB() would be faster than Len().


More functions in coming articles...

Cheers
Shasur






Free Search Engine Submission

BreakLinks - Microsoft Excel

Use the following code to break the links to external source in Microsoft Excel Workbook


Sub Break_XL_Links()

Dim oXlLinks

oXlLinks = ActiveWorkbook.LinkSources(xlExcelLinks)

MsgBox UBound(oXlLinks)

For i = 1 To UBound(oXlLinks)
MsgBox oXlLinks(i)
Next i

ActiveWorkbook.Breaklink Name:=oXlLinks(1), Type:=xlLinkTypeExcelLinks

End Sub

Removing External Links in Microsoft Excel SpreadSheet

Removing External Links in Excel SpreadSheet:

Some Microsoft Excel Spreadsheet will have links to other workbooks. If this needs to be broken use the following code:

Sub Remove_External_Links_in_Cells()

Dim LinkCell
Dim FormulaCells As Range
Dim SheetsInWorkbook As Object

For Each SheetsInWorkbook In Sheets
SheetsInWorkbook.Activate
'*** Error trapping if no formulacells found
On Error Resume Next
'*** Select only formula cells
Set FormulaCells = Cells.SpecialCells(xlFormulas)
'*** Loop every formulacell in sheet
For Each LinkCell In FormulaCells
'*** If you want paste linked value as "normal value"
MsgBox LinkCell.Parent.Name
If InStr(1, LinkCell.Value, ".xls]") = 0 Then
LinkCell.Value = LinkCell
End If
Next
Next
End Sub

Filler Function

Filler Function for Microsoft Excel

Function Filler(ByVal sBase As String, ByVal sFiller As String, ByVal iLen As Integer) As String

' ******** Filler **************************************
' Generic Function to stuff characters as prefix to a string
' ******************************************************

Dim i As Integer
If iLen > Len(sBase) Then
For i = Len(sBase) To iLen - 1
sBase = sFiller & sBase '* Stuff the string with specified filler characters
Next i
End If
Filler = sBase '* Return the stuffed string

End Function

This function can be used to fill equal number of spaces or fill zeroes for any string.


This can be used for Microsoft EXcel and also in Visual Basic PRograms

Automating Excel in ASP.Net

Automating Excel or Word (or any Office product) is not recommended:

Problems using Automation of Office server-side

Developers who try to use Office in a server-side solution need to be aware of five major concerns in which Office behaves differently than anticipated because of the environment. If your code is to run successfully, these concerns need to be addressed and their effects minimized as much as possible. Consider these items carefully when you build your application because no one solution can address all of them, and different designs require you to prioritize the elements differently.
1.
User Identity: Office Applications assume a user identity when they are run, even when they are started by Automation. They attempt to initialize toolbars, menus, options, printers, and some add-ins based on settings in the user registry hive for the user who launches the application. Many services run under accounts that have no user profiles (such as the SYSTEM or IWAM_[servername] accounts), and therefore Office may fail to initialize properly on startup, returning an error on CreateObject or CoCreateInstance. Even if the Office application can be started, without a user profile other functions may fail to work properly. If you plan to Automate Office from a service, you need to configure either your code or Office so that it will run with a loaded user profile.
2.
Interactivity with the Desktop: Office Applications assume that they are being run under an interactive desktop, and may in some circumstances need to be made visible for certain Automation functions to work properly. If an unexpected error occurs, or an unspecified parameter is needed to complete a function, Office is designed to prompt the user with a modal dialog box that asks the user what they want to do. A modal dialog box on a non-interactive desktop cannot be dismissed, which causes that thread to stop responding (hang) indefinitely. Although certain coding practices can help reduce the likelihood of this occurring, they cannot prevent it entirely. This fact alone makes running Office Applications from a server-side environment risky and unsupported.
3.
Reentrancy and Scalability: Server-side components need to be highly reentrant, multi-threaded COM components with minimum overhead and high throughput for multiple clients. Office Applications are in almost all respects the exact opposite. They are non-reentrant, STA-based Automation servers that are designed to provide diverse but resource-intensive functionality for a single client. They offer little scalability as a server-side solution, and have fixed limits to important elements, such as memory, which cannot be changed through configuration. More importantly, they use global resources (such as memory mapped files, global add-ins or templates, and shared Automation servers), which can limit the number of instances that can run concurrently and lead to race conditions if they are configured in a multi-client environment. Developers who plan to run more then one instance of any Office Application at the same time need to consider "pooling" or serializing access to the Office Application to avoid potential deadlocks or data corruption.
4.
Resiliency and Stability: Office 2000, Office XP, and Office 2003 use Microsoft Windows Installer (MSI) technology to make installation and self-repair easier for an end user. MSI introduces the concept of "install on first use", which allows features to be dynamically installed or configured at runtime (for the system, or more often for a particular user). In a server-side environment this both slows down performance and increases the likelihood that a dialog box may appear that asks for the user to approve the install or provide an appropriate install disk. Although it is designed to increase the resiliency of Office as an end-user product, Office's implementation of MSI capabilities is counterproductive in a server-side environment. Furthermore, the stability of Office in general cannot be assured when run server-side because it has not been designed or tested for this type of use. Using Office as a service component on a network server may reduce the stability of that machine, and as a consequence your network as a whole. If you plan to automate Office server-side, attempt to isolate the program to a dedicated computer that cannot affect critical functions, and that can be restarted as needed.
5.
Server-Side Security: Office Applications were never intended for use server-side, and therefore do not take into consideration the security problems that are faced by distributed components. Office does not authenticate incoming requests, and does not protect you from unintentionally running macros, or starting another server that might run macros, from your server-side code. Do not open files that are uploaded to the server from an anonymous Web! Based on the security settings that were last set, the server can run macros under an Administrator or System context with full privileges and compromise your network! In addition, Office uses many client-side components (such as Simple MAPI, WinInet, MSDAIPP) that can cache client authentication information in order to speed up processing. If Office is being automated server-side, one instance may service more than one client, and because authentication information has been cached for that session, it is possible that one client can use the cached credentials of another client, and thereby gain non-granted access permissions by impersonating other users.


(courtesy: http://support.microsoft.com/default.aspx?scid=kb;EN-US;257757)

ASP.Net Tips & Tricks http://aspdud.blogspot.com/