Opening Dynamic Text file in Excel

Query Table for Text / CSV Files

If you update some Excel frequently, you can keep it as shared and then ask your fellow colleagues to check if often (refresh)

One of the good option is to have them as CSV file and use query table to update it regularly

Sub TXT_QueryTable()

Dim ConnString As String

Dim qt As QueryTable

ConnString = "TEXT;C:\Temp.txt"


Set qt = Worksheets(1).QueryTables.Add(Connection:=ConnString, _
Destination:=Range("B1"))

qt.Refresh



End Sub


The Refresh method causes Microsoft Excel to connect to the query table’s data source, execute the SQL query, and return data to the query table destination range. Until this method is called, the query table doesn’t communicate with the data source.

Query Table with Excel as Data Source

Query tables can be of great help if you need to extract particular data from a data source

It represents a worksheet table built from data returned from an external data source, such as an SQL server or a Microsoft Access database. The QueryTable object is a member of the QueryTables collection

However, it need to be SQL server or a Microsoft Access database always. You can use CSV file or our fellow Microsoft Excel spreadsheet as a data source for QueryTable

Here is one such example, which extracts data from MS Excel sheet


Sub Excel_QueryTable()

Dim oCn As ADODB.Connection
Dim oRS As ADODB.Recordset
Dim ConnString As String
Dim SQL As String

Dim qt As QueryTable

ConnString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\SubFile.xls;Extended Properties=Excel 8.0;Persist Security Info=False"
Set oCn = New ADODB.Connection
oCn.ConnectionString = ConnString
oCn.Open

SQL = "Select * from [Sheet1$]"

Set oRS = New ADODB.Recordset
oRS.Source = SQL
oRS.ActiveConnection = oCn
oRS.Open

Set qt = Worksheets(1).QueryTables.Add(Connection:=oRS, _
Destination:=Range("B1"))

qt.Refresh

If oRS.State <> adStateClosed Then
oRS.Close
End If


If Not oRS Is Nothing Then Set oRS = Nothing
If Not oCn Is Nothing Then Set oCn = Nothing

End Sub

Use the Add method to create a new query table and add it to the QueryTables collection.

You can loop through the QueryTables collection and Refresh / Delete Query Tables

If you use the above code for Excel 2010, you need to change the connection string to  the following

ConnString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\Om\Documents\SubFile.xlsx;Extended Properties=Excel 12.0;Persist Security Info=False"
Else it will thrown an 3706 Provider cannot be found. It may not be properly installed. error

See also:

Opening Comma Separate File (CSV) through ADO

Using Excel as Database using VBA (Excel ADO)

Create Database with ADO / ADO Create Database

ADO connection string for Excel

Combining Text Files using VBA

Visual Basic Application to Merge Text Files

Multiple utilities are available to split & merge text files. However, here is a simple one my friend uses to merge around 30 ascii files into one

It uses File System Object and you need to add a reference of Microsoft Scripting Runtime

Sub Append_Text_Files()

Dim oFS As FileSystemObject
Dim oFS1 As FileSystemObject

Dim oTS As TextStream
Dim oTS1 As TextStream

Dim vTemp

Set oFS = New FileSystemObject
Set oFS1 = New FileSystemObject


For i1 = 1 To 30

Set oTS = oFS.OpenTextFile("c:\Sheet" & i1 & ".txt", ForReading)
vTemp = oTS.ReadAll

Set oTS1 = oFS.OpenTextFile("c:\CombinedTemp.txt", ForAppending, True)
oTS1.Write (vTemp)

Next i1

End Sub

The code is simple.. it searches for files from Sheet1.txt ...Sheet30.txt and copies the content into one variable. Then it appends the content to CombinedTemp.txt

Open XML File in Excel

Here are the primitive commands to open an XML file in Microsoft Excel.

Sub Open_XML_File()

Dim oWX As Workbook

Set oWX = Workbooks.OpenXML("c:\sample.xml")

End Sub




Sub Open_XML_File_As_List()

Dim oWX As Workbook

Set oWX = Workbooks.OpenXML(Filename:="c:\sample.xml", LoadOption:=XlXmlLoadOption.xlXmlLoadImportToList)

End Sub


This option will work for Excel 2003 and above

Visual Basic - Special Folders (Temp Folder , System Folder)

Here is a simple routine to get special folders like temporary folder etc:

Sub Get_Special_Folders()

' Uses File System Object
' Need to have reference to Microsoft Scripting Runtime

On Error GoTo Show_Err

Dim oFS As FileSystemObject
Dim sSystemFolder As String
Dim sTempFolder As String
Dim sWindowsFolder As String

Set oFS = New FileSystemObject

' System Folder - Windows\System32
sSystemFolder = oFS.GetSpecialFolder(SystemFolder)

' Temporary Folder Path
sTempFolder = oFS.GetSpecialFolder(TemporaryFolder)

' Windows Folder Path
sWindowsFolder = oFS.GetSpecialFolder(WindowsFolder)

Dim a
a = oFS.GetFolder("m:\9.3 BulkLoad\BLT1_Base15.6\Reports\08-Nov-2007\Output\")

If Not oFS Is Nothing Then Set oFS = Nothing

Show_Err:

If Err <> 0 Then
MsgBox Err.Number & " - " & Err.Description
Err.Clear
End If
End Sub

You need to have reference to Microsoft Scripting Runtime to execute the above code

Array Dimensioning in Visual Basic

Dimensioning Arrays in Visual Basic

The ReDim statement is used to size or resize a dynamic array that has already been formally declared using a Private, Public, or Dim statement with empty parentheses (without dimension subscripts).

You can use the ReDim statement repeatedly to change the number of elements and dimensions in an array. However, you can't declare an array of one data type and later use ReDim to change the array to another data type, unless the array is contained in a Variant. If the array is contained in a Variant, the type of the elements can be changed using an As type clause, unless you’re using the Preserve keyword, in which case, no changes of data type are permitted.

If you use the Preserve keyword, you can resize only the last array dimension and you can't change the number of dimensions at all. For example, if your array has only one dimension, you can resize that dimension because it is the last and only dimension. However, if your array has two or more dimensions, you can change the size of only the last dimension and still preserve the contents of the array. The following example shows how you can increase the size of the last dimension of a dynamic array without erasing any existing data contained in the array.

Here is an example of Array redimensioning

Sub Array_Dimensioning()

Dim arPreserved() As Integer ' Preserved Array
Dim arErased() As Integer ' Array without Preserve

ReDim Preserve arPreserved(1, 1)
ReDim arErased(1, 1)

arPreserved(1, 1) = 1

ReDim Preserve arPreserved(1, 2)
arPreserved(1, 2) = 2

ReDim Preserve arPreserved(1, 3)
arPreserved(1, 3) = 3

ReDim Preserve arPreserved(2, 3) ' This statement will throw and error

' whereas the following statement will not as the Array is not preserved (Erased)
ReDim arErased(2, 1)

End Sub

If you use the Preserve keyword, you can resize only the last array dimension and you can't change the number of dimensions at all. For example, if your array has only one dimension, you can resize that dimension because it is the last and only dimension. However, if your array has two or more dimensions, you can change the size of only the last dimension and still preserve the contents of the array. The arPreserved falls under this category. However, arErased you can redimension the array in any dimension, but the contents will be erased with every Redim statement

Comparing two Word Documents using Word VBA

Compare Word Documents using VBA

Here is a simple routine, which will compare two Microsoft Word documents and return the status.


Sub IsDocument_Equal()

Dim oDoc1 As Word.Document
Dim oResDoc As Word.Document

' Delete the tables from both the document

' Delete the images from both the document

' Replace Paragraphs etc

Set oDoc1 = ActiveDocument

' comparing Document 1 with New 1.doc
oDoc1.Compare Name:="C:\New 1.doc", CompareTarget:=wdCompareTargetNew, DetectFormatChanges:=True

'This will be the result document
Set oResDoc = ActiveDocument

If oResDoc.Revisions.Count <> 0 Then
'Some changes are done
MsgBox "There are Changes "
Else
MsgBox "No Changes"
End If

End Sub

Convert URLs to Hyperlinks using VBA

Automatically create Hyperlinks for all URLs in a document

Microsoft Word has in-built intelligence to convert the URLs or Web Addresses to Hyperlinks automatically. This functionality is executed when you type some website/email address in word document.

For some reason, if you want to be done on the Word document at a later stage you can do the following:

Sub Make_URLs_as_HyperLinks()


Options.AutoFormatReplaceHyperlinks = True
ActiveDocument.Select
Selection.Range.AutoFormat
Selection.Collapse

Options.AutoFormatReplaceSymbols
End Sub

Warning: I have set only AutoFormatReplaceHyperlinks = True and not set/reset others. You need to check all options as autocorrect/autoformat can cause undesirable changes that might go unnoticed

Run a Automatic Macro in Word Document

Execute Word Macro on File Open

There are numerous instances where one stores the word document format as a Microsoft Word template. When the user opens the document (using the template), some macro needs to be executed. This can be achieved by RunAutoMacro Method of Word VBA

Sub Run_Macro_In_WordDocument()

Dim oWD As Word.Document
Set oWD = Documents.Add("c:\dcomdemo\sample.dot")
oWD.RunAutoMacro wdAutoOpen

End Sub

Here a new document is open based on the Sample.dot template and once the document is open the AutoOpen macro is fired

RunAutoMacro Method can be used to execute an auto macro that's stored in the specified document. If the specified auto macro doesn't exist, nothing happens

On the other hand, if a normal macro (not auto open etc) needs to be executed, Run method can be used

Application.Run "Normal.FormatBorders"



Create Database with ADO / ADO Create Database

Create Microsoft Access Database programmatically using ADO

Programmers who have used DAO will definitely miss the CreateDatabase in ADO. Here is one method to do the same using ADO.

For doing this you need to include the ADO Extensions library in the project reference.


This library consists of classes and methods to handle the Schema related activities like creation of database, table etc

The following code uses the Catalog object of the ADOX to create a new Microsoft Access database

Sub Create_DB_and_Table_Using_ADOX()

Dim oDB As ADOX.Catalog
Dim sDBPAth As String

Dim sConStr As String
Dim oCn As ADODB.Connection
Dim oCM As ADODB.Command

' ------------------------
' Set the Path and Connection String
' ------------------------
sDBPAth = "c:\Temp\MyAccounts.mdb"
sConStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sDBPAth & ";"

' ------------------------
' Create New ADOX Object
' ------------------------
Set oDB = New ADOX.Catalog
oDB.Create sConStr

Set oCn = New ADODB.Connection
oCn.ConnectionString = sConStr
oCn.Open

Set oCM = New ADODB.Command
oCM.ActiveConnection = oCn
oCM.CommandText = "Create Table Users (" & _
"[EmpNo] Decimal(6), " & _
"[EmpName] Text(150), " & _
"[JoinDate] Date " & _
")"
oCM.Execute
' ------------------------
' Release / Destroy Objects
' ------------------------
If Not oCM Is Nothing Then Set oCM = Nothing
If Not oCn Is Nothing Then Set oCn = Nothing
If Not oDB Is Nothing Then Set oDB = Nothing


' ------------------------
' Error Handling
' ------------------------
Err_Handler:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End Sub

Though I used the ADODB Query deliberately to create a Table in the new database, you can try it with the Table object in ADOX

Excel VBA - FindAll Method

One out of two code module in Excel VBA will have cells.Find or Findnext method. Here is a generic function - FindAll that can be used to retrieve information of all matching cells.

Function FindAll(ByVal sText As String, ByRef oSht As Worksheet, ByRef sRange As String, ByRef arMatches() As String) As Boolean

' --------------------------------------------------------------------------------------------------------------
' FindAll - To find all instances of the1 given string and return the row numbers.
' If there are not any matches the function will return false
' --------------------------------------------------------------------------------------------------------------

On Error GoTo Err_Trap

Dim rFnd As Range ' Range Object
Dim iArr As Integer ' Counter for Array
Dim rFirstAddress ' Address of the First Find

' -----------------
' Clear the Array
' -----------------
Erase arMatches
Set rFnd = oSht.Range(sRange).Find(What:=sText, LookIn:=xlValues, LookAt:=xlPart)
If Not rFnd Is Nothing Then
rFirstAddress = rFnd.Address
Do Until rFnd Is Nothing
iArr = iArr + 1
ReDim Preserve arMatches(iArr)
arMatches(iArr) = rFnd.Address ' rFnd.Row ' Store the Row where the text is found
Set rFnd = oSht.Range(sRange).FindNext(rFnd)
If rFnd.Address = rFirstAddress Then Exit Do ' Do not allow wrapped search
Loop
FindAll = True
Else
' ----------------------
' No Value is Found
' ----------------------
FindAll = False
End If


' -----------------------
' Error Handling
' -----------------------
Err_Trap:
If Err <> 0 Then
MsgBox Err.Number & " " & Err.Description, vbInformation, "Find All"
Err.Clear
FindAll = False
Exit Function
End If
End Function

The functions accepts three input parameters - Text To be searched, Worksheet, Search Range and one output Array parameter

The function searches the occurrence of that particular text in the specified range of the Excel Sheet and returns address(es) of all occurrences. The Search is by default part of Excel Cells and not whole cell

Here is a way to implement the function:

Case I : Get Addresses of all matching cells

Sub Drive_The_FindAll_Function()

' Sample Sub to Drive the Function

Dim arTemp() As String 'Temp Array
Dim bFound As Boolean 'Flag
Dim i1 As Integer 'Array Counter

bFound = FindAll("SampleText", ActiveSheet, "B1:C41", arTemp())

If bFound = True Then
For i1 = 1 To UBound(arTemp)
' The Address Can be used for extracting data
MsgBox arTemp(i1)
Next i1
Else
MsgBox "Search Text Not Found"
End If



End Sub

Case II : Modify Data according to Find

In the example shown below, FindAll function is used to search 'SampleText' in column C and if the text is found a Flag 'X' is set against column D

Sub Fill_Based_on_FindAll()

' For All Matching Values in Second Column
' Add 'X' to Column D

Dim arTemp() As String 'Temp Array
Dim bFound As Boolean 'Flag
Dim i1 As Integer 'Array Counter


bFound = FindAll("SampleText", ActiveSheet, "C:C", arTemp())

If bFound = True Then
For i1 = 1 To UBound(arTemp)
' The Row Number Can be used for extracting data
ActiveSheet.Range(arTemp(i1)).Offset(0, 1).Value = "X"
Next i1
Else
MsgBox "Search Text Not Found"
End If



End Sub

Case III : Get the Number of Occurrences

A simple one though; number of occurrences of the text in particular range

Sub Instances_Based_on_FindAll()

' Get the Number of Instances

Dim arTemp() As String 'Temp Array
Dim bFound As Boolean 'Flag
Dim i1 As Integer 'Array Counter


bFound = FindAll("SampleText", ActiveSheet, "C:C", arTemp())

If bFound = True Then
MsgBox "No of instances : " & UBound(arTemp)
Else
MsgBox "Search Text Not Found"
End If



End Sub

Disabling Macros in a Workbook (Excel VBA)

Many workbooks will have macros embedded with it. When you open the Workbook in Excel, you would have noticed the Dialog with options Enable Macros / Disable Macros

The following code snippet (Excel 2003) uses Application.FileDialog method to open a Workbook and disables the macros in it:

Sub Open_File_With_Macros_Disabled()

Dim i1 As Integer
Dim secAutomation As MsoAutomationSecurity

secAutomation = Application.AutomationSecurity

Application.AutomationSecurity = msoAutomationSecurityForceDisable

With Application.FileDialog(msoFileDialogOpen)
.Show
For i1 = 1 To .SelectedItems.Count
MsgBox .SelectedItems(i1)
Workbooks.Open .SelectedItems(i1)

Next i1
End With

Application.AutomationSecurity = secAutomation

End Sub

Automate Lotus Notes eMail using Visual Basic

How to send Lotus Notes mail messages with Microsoft Visual Basic

The following Visual Basic code will send a Notes e-mail message. The code includes examples of code to include an attachment and to save the sent message, which are both optional and can be removed if desired.

Dim Maildb As Object
Dim MailDoc As Object
Dim Body As Object
Dim Session As Object
'Start a session to notes
Set Session = CreateObject("Lotus.NotesSession")
'This line prompts for password of current ID noted in Notes.INI
Call Session.Initialize
'or use below to supply password of the current ID
'Call Session.Initialize("")
'Open the mail database in notes
Set Maildb = Session.GETDATABASE("", "c:\notes\data\mail\mymail.nsf")
If Not Maildb.IsOpen = True Then
Call Maildb.Open
End If
'Create the mail document
Set MailDoc = Maildb.CREATEDOCUMENT
Call MailDoc.ReplaceItemValue("Form", "Memo")
'Set the recipient
Call MailDoc.ReplaceItemValue("SendTo", "John Doe")
'Set subject
Call MailDoc.ReplaceItemValue("Subject", "Subject Text")
'Create and set the Body content
Set Body = MailDoc.CREATERICHTEXTITEM("Body")
Call Body.APPENDTEXT("Body text here")
'Example to create an attachment (optional)
Call Body.ADDNEWLINE(2)
Call Body.EMBEDOBJECT(1454, "", "C:\filename", "Attachment")
'Example to save the message (optional)
MailDoc.SAVEMESSAGEONSEND = True
'Send the document
'Gets the mail to appear in the Sent items folder
Call MailDoc.ReplaceItemValue("PostedDate", Now())
Call MailDoc.SEND(False)
'Clean Up
Set Maildb = Nothing
Set MailDoc = Nothing
Set Body = Nothing
Set Session = Nothing

Note: The Visual Basic programmer needs to set the Reference to use Lotus Domino objects prior to implementing this function. To enable the Lotus Notes classes to appear in the Visual Basic browser, you must execute the following within VB: Select Tools, References and select the checkbox for 'Lotus Notes Automation Classes'.

The above code is from the IBM support. GETDATABASE given here is pointing to the sample MailDB; you need to change that to your DB.

You can do that by

UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
'Open the mail database in notes
Set Maildb = Session.GETDATABASE("", MailDbName)

To send it through Microsoft Outlook refer http://vbadud.blogspot.com/2007/04/vba-email-automation-vba-mail.html

Automate Email, VBA Email, Send Email from Excel, VBA Mail automation, Mail Automation, Lotus Notes VBA, Automate Lotus Notes, Send Mail from Lotus Notes, Link Excel with Lotus Notes,Microsoft Lotus Notes Mail Automation, Excel VBA Mail, MAPI, Send Multiple eMails

Reducing Size of Microsoft Access Database (Compact Database)

Compact MS Access Database using VBA (ADO Code)

If the DB Size is huge the compact DB utility [Compact & Repair Database (Tools-->Database utilities-->Compact and Repair Database) should reduce the DB Size.

Here is the code for doing the same using VB/VBA (ADO)

Public Sub CompactDB()
'Microsoft Jet and Replication objects
Dim objJE As New JRO.JetEngine, strSource As String, strTarget As String
DoEvents
Busy True
strSource = " "
strTarget = " "
objJE.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strSource & ";", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strTarget & ";Jet OLEDB:Engine Type=4;"
Busy False
'Engine type:
'Access 97 = 4
'Access 2000 = 5
End Sub

Excel VBA - Change Font Color for Part of Text

Formatting Text (Cell Contents) Partially using Excel VBA

Sometimes, you need to differentiate some parts of text in an Excel cell. This can be done using formatting those characters.

Here is the way that can be done using VBA using the Characters property


Sub Color_Part_of_Cell()
'Print ActiveCell.Characters.Count
With ActiveCell.Characters(2).Font
.Color = RGB(36, 182, 36)
End With

With ActiveCell.Characters(2, 2).Font
.Color = RGB(36, 182, 36)
End With

With ActiveCell.Characters(, 2).Font
.Color = RGB(36, 182, 36)
End With

End Sub

The output of the above is

Syntax

expression.Characters(Start, Length)

expression Required. An expression that returns an object in the Applies To list.

Start Optional Variant. The first character to be returned. If this argument is either 1 or omitted, this property returns a range of characters starting with the first character.

Length Optional Variant. The number of characters to be returned. If this argument is omitted, this property returns the remainder of the string (everything after the Start character)

The same characters object can be used to make a character Bold / Italic

Orientation of Cell Through Excel VBA

Almost most of the Excel VBA programmers would have the requirement to change the orientation of the cell.

Here is an example

Sub Orientations()

ActiveCell.Orientation = xlHorizontal
ActiveCell.Orientation = xlVertical
ActiveCell.Orientation = xlUpward
ActiveCell.Orientation = xlDownward
ActiveCell.Orientation = 45
ActiveCell.Orientation = -45

End Sub

The orientation of the cell in Excel would be as follows:

ShutDown Windows using VBA

VBA Function to Logoff /VBA Function to Restart Windows



Option Explicit

' Win API Declarations

Const MF_BYPOSITION = &H400&

Private Const EWX_LOGOFF = 0
Private Const EWX_SHUTDOWN = 1
Private Const EWX_REBOOT = 2
Private Const EWX_FORCE = 4

Private Declare Function ExitWindowsEx Lib "user32.dll" ( _
ByVal uFlags As Long, _
ByVal dwReserved As Long) As Long


Use the function with atmost caution, you will not be warned by Windows for Shutdown / Restart. Save all your work before trying this example:)

Function Common_ShutDown_Logoff()


'Shutdown Windows
Call ExitWindowsEx(EWX_SHUTDOWN, 0)

'Restart Windows
Call ExitWindowsEx(EWX_REBOOT, 0)

'logoff Windows
Call ExitWindowsEx(EWX_LOGOFF, 0)


End Function

Disable Close Button in UserForm (VBA)

Disable Close Button in Userform (Visual Basic)

Option Explicit

'API Declarations

Const MF_BYPOSITION = &H400&


Private Declare Function GetSystemMenu Lib "user32" _
(ByVal hwnd As Long, _
ByVal bRevert As Long) As Long

Private Declare Function RemoveMenu Lib "user32" _
(ByVal hMenu As Long, _
ByVal nPosition As Long, _
ByVal wFlags As Long) As Long




Public Sub DisableCloseWindowButton(frm As Form)

Dim hSysMenu As Long

'Get the handle of the Window
hSysMenu = GetSystemMenu(frm.hwnd, 0)

'Disable the close button of the Form
RemoveMenu hSysMenu, 6, MF_BYPOSITION

'Remove the seperator bar
RemoveMenu hSysMenu, 5, MF_BYPOSITION

End Sub

Detecting duplicate values (Excel VBA)

Check presence of values in a column/range using Excel VBA

Most often a programmer would be given a job of Insert/Update scenarion in EXcel. That is, Insert a new row if a specific value does not exist; if it does then update some. So the process is to check for existence of a specific value

Here is a generic function ;

Sub CheckForExistence()

myVal = "Sample"
myRange = "A:A"
If Check_Val_Existence(myVal, myRange) = True Then
MsgBox "Value exists"
End If
End Sub

This used the Find Method. This method finds specific information in a range, and returns a Range object that represents the first cell where that information is found. Returns Nothing if no match is found.


Function Check_Val_Existence(ByVal sText, ByVal sRange) As Boolean

Dim rFnd As Range
Dim sText As String

Set rFnd = ActiveSheet.Range(sRange).Find(What:=sText, LookAt:=xlPart)
If Not rFnd Is Nothing Then
Check_Val_Existence = True
Else
Check_Val_Existence = False
End If

End Function

Automatically Event Repeat in Excel VBA (OnTime Method)

VBA Code that can run at a fixed time can be done using the OnTime Method.

OnTime Method schedules a procedure to be run at a specified time in the future (either at a specific time of day or after a specific amount of time has passed).

expression.OnTime(EarliestTime, Procedure, LatestTime, Schedule)

expression Required. An expression that returns an Application object.

EarliestTime Required Variant. The time when you want this procedure to be run.

Procedure Required String. The name of the procedure to be run.

LatestTime Optional Variant. The latest time at which the procedure can be run. For example, if LatestTime is set to EarliestTime + 30 and Microsoft Excel is not in Ready, Copy, Cut, or Find mode at EarliestTime because another procedure is running, Microsoft Excel will wait 30 seconds for the first procedure to complete. If Microsoft Excel is not in Ready mode within 30 seconds, the procedure won’t be run. If this argument is omitted, Microsoft Excel will wait until the procedure can be run.

Schedule Optional Variant. True to schedule a new OnTime procedure. False to clear a previously set procedure. The default value is True.

Remarks

Use Now + TimeValue(time) to schedule something to be run when a specific amount of time (counting from now) has elapsed. Use TimeValue(time) to schedule something to be run a specific time.

Application.OnTime TimeValue("11:00:00"), "StartProc"
Application.OnTime TimeValue("13:00:00"), "EndProc"

Assuming that you have two procedures called StartProc and EndProc the procedures would ne executed at the specified time

Disable Cut & Copy from Popup menu (Excel VBA/Word VBA)

Here is a simple way to disable the Cut & Copy in the Popup menu

Sub Disable_Buttons()

Dim oC1 As CommandBar

Set oC1 = Application.CommandBars("CELL")
oC1.Controls("Cu&t").Enabled = False
oC1.Controls("&Copy").Enabled = False

End Sub

Other menu items can also be handled similarly

To disable the Insert & Delete in the Popup menu

oC1.Controls("&Insert...").Enabled = False
oC1.Controls("&Delete...").Enabled = False

Excel Height of Row - RowHeight using Excel VBA

RowHeight property is used to get the Height

Returns the height of all the rows in the range specified, measured in points (point: Unit of measure referring to the height of a printed character. A point equals 1/72 of an inch, or approximately 1/28 of a centimeter.). Returns null if the rows in the specified range aren’t all the same height. Read/write Variant.

You can use the Height property to return the total height of a range of cells.


Sub Change_Header_Row_Height()


MsgBox "RowHeight = " & Range("A1").RowHeight _
& vbCrLf & "Height = " & Range("A1").Height

Range("A1").RowHeight = 90

End Sub


Differences between RowHeight and Height include the following:

Height is read-only.

If you return the RowHeight property of several rows, you will either get the row height of each of the rows (if all the rows are the same height) or null (if they’re different heights). If you return the Height property of several rows, you will get the total height of all the rows.


Range("A1").Height = 90

would give Object required 424 error

Technorati Profile

Get the Height & Width of Shapes / Figures in Word Document (Word VBA)

Height & Width of Shapes / InlineShapes in Word Document (Word VBA)

Figures are embedded in the word document and when they move they are a nemesis. Programmers are often given the job of aligning, resizing etc. Here is a simple example to get the height of the Shapes. Here you will notice that a particular inline shape has been singled out. You will get to know this if you run this in the document:)

Sub Figure_Attributes()
Dim sRep
sRep = ""
For I = 1 To ActiveDocument.InlineShapes.Count
If ((ActiveDocument.InlineShapes(I).Type > 0 And ActiveDocument.InlineShapes(I).Type <> 7 And ActiveDocument.InlineShapes(I).Type < 18)) Then
Height = ActiveDocument.InlineShapes(I).Height
Width1 = ActiveDocument.InlineShapes(I).Width
ActiveDocument.InlineShapes(I).Select
If Selection.Fields.Count = 0 Then
sRep = sRep & fname & vbTab & Height & vbTab & Width1 & vbCr
End If
End If
Next I
For I = 1 To ActiveDocument.Shapes.Count
Height = ActiveDocument.Shapes(I).Height
Width1 = ActiveDocument.Shapes(I).Width
ActiveDocument.Shapes(I).Select
sRep = sRep & fname & vbTab & Height & vbTab & Width1 & vbCr
Next I
MsgBox "Attributes of all the shapes in " & ActiveDocument.Name & vbCrLf & sRep
End Sub

Paragraph & Character Styles in Word Document (Word VBA)

Export Character Styles from Word Document / Export Paragraph Styles from Word Document

Here is the simple macro for extracting character & paragraph styles from a Word document. This exports the styles to a new word document



Sub Export_Styles_In_Document()

Dim oSource As Document
Dim oRep As Document
Dim oPara As Paragraph

Set oRep = Documents.Add



Set oSource = ActiveDocument
For I = 1 To oSource.Styles.Count
If oSource.Styles(I).Type = wdStyleTypeParagraph Then
SType = "Para"
oRep.Bookmarks("\EndOfDoc").Select
Set oPara = oRep.Paragraphs.Add
Set oPara = oRep.Paragraphs.Add
oPara.Range.Text = SType & ": " & oSource.Styles(I).NameLocal
Else
SType = "Char"
End If
Next I
For I = 1 To oSource.Styles.Count
If oSource.Styles(I).Type = wdStyleTypeParagraph Then
SType = "Para"
Else
SType = "Char"
oRep.Bookmarks("\EndOfDoc").Select
Set oPara = oRep.Paragraphs.Add
Set oPara = oRep.Paragraphs.Add
oPara.Range.Text = SType & ": " & oSource.Styles(I).NameLocal
End If
Next I
oRep.Activate
End Sub


Visual Basic Common Dialog

Opening Files with Common Dialog

Common Dialog not only replaces three controls (Drive, Directory and FileList), but also is easier to program. It is supported in Visual Basic and VBA as well. The new VB.NET has the same functionality in the OpenFileDialog class

Let us have a small form created for explaining CommonDialog. Let us have a small form with a Text Box and a Command Button. On Clicking the Command Button, the selected file should be displayed in the Text Box

Sample Form:



To use the CommonDialog you need to include the component to your project. You can do so as follows:





Once The component is included, the CommonDialog will be displayed in the ToolBox




Drag the CommonDialog to the form. You will see a small rectangle there. CommonDialog is visible in the Design time only (it is not visible during runtime)




Add the following code to show the CommonDialog box and show the selected file in the text box


Private Sub Command1_Click()

CommonDialog1.DialogTitle = "Select the File..."

CommonDialog1.Flags = cdlOFNFileMustExist

CommonDialog1.Filter = "Microsoft Excel Workbooks (*.xls)*.xls"

CommonDialog1.ShowOpen

If Len(CommonDialog1.FileName) <> 0 Then

Text1.Text = CommonDialog1.FileName

End If






You can restrict the type of files to be selected using the filter Command. Some common filters are




Selecting Microsoft Word Documents
CommonDialog1.Filter = "Microsoft Word Documents (*.doc)*.docMicrosoft Word Documents (*.rtf)*.rtf"

Selecting Image Files
CommonDialog1.Filter = "Image Files(*.BMP;*.JPG;*.GIF)*.BMP;*.JPG;*.GIF"

Selecting Microsoft Word Documents (Including RTF Files)
CommonDialog1.Filter = "Microsoft Word Documents (*.doc;*.rtf)*.doc;*.rtf"

Selecting Microsoft Excel Workbooks
CommonDialog1.Filter = "Microsoft Excel Workbooks (*.xls)*.xls"

Selecting Excel Addins
CommonDialog1.Filter = "Microsoft Excel Addins (*.xla;*.xll)*.xla;*.xll"

Selecting Any files
CommonDialog1.Filter = "All files (*.*)*.*"

Selecting Text files
CommonDialog1.Filter = "Text files (*.txt)*.txt"

Selecting ASCII files
CommonDialog1.Filter = "ASCII files (*.txt;*.log)*.txt;*.log"

See also:

OpenFileDialog in Visual Basic .Net

Search and Open Files using Excel VBA (FileSearch)

Open Excel Files - Open Dialog - GetOpenFilename Method

Selecting a Folder in VB.Net

Browse a Folder / Select a Folder Thru Shell

SaveAs Dialog - Controlled Save

Excel VBA - install an Excel Add-in (XLA or XLL)

Adding Addins Automatically using VBA


Most of today's Excel VBA code are as Addins (XLA or XLL). As an organization progresses there comes many revisions for the Addin - hence the need to update the program.

Here is a simple way to add a new addin:

Sub Add_an_Addin()

Dim oAddin As AddIn
Dim oTempBk As Workbook


Set oTempBk = Workbooks.Add

Set oAddin = AddIns.Add("E:\CostBenefit1.0.xla", True)
oAddin.Installed = True

oTempBk.Close

End Sub


If you wonder why a temporary workbooks is added - it is because to avoid the Run-time error '1004': Unable to get the Add property of the AddIns class or Run-time error '1004': Add method of addins class failed exceptions that are raised when there are no workbooks. Just be safe!!

Show All Processes using VBA

Get All Processes using Win API Functions

'Declarations
Const TH32CS_SNAPHEAPLIST = &H1
Const TH32CS_SNAPPROCESS = &H2
Const TH32CS_SNAPTHREAD = &H4
Const TH32CS_SNAPMODULE = &H8
Const TH32CS_SNAPALL = (TH32CS_SNAPHEAPLIST Or TH32CS_SNAPPROCESS Or TH32CS_SNAPTHREAD Or TH32CS_SNAPMODULE)
Const TH32CS_INHERIT = &H80000000
Const MAX_PATH As Integer = 260
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * MAX_PATH
End Type
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Sub CloseHandle Lib "kernel32" (ByVal hPass As Long)

' API Functions to get the processes
Private Declare Function Process32First Lib "kernel32" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long


Sub Load_Process_To_ListBox()


Dim hSnapShot As Long '* Handle
Dim uProcess As PROCESSENTRY32 '* Process
Dim lRet '* Return Val

On Error Resume Next

'Takes a snapshot of the running processes and the heaps, modules, and threads used by the processes
hSnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0&)

uProcess.dwSize = Len(uProcess)

'Retrieve information about the first process encountered in our system snapshot

lRet = Process32First(hSnapShot, uProcess)

Do While lRet
lRet = Process32Next(hSnapShot, uProcess)

' Trim the unwanted characters at the end of process
lstProcess.AddItem Left$(uProcess.szExeFile, IIf(InStr(1, uProcess.szExeFile, Chr$(0)) > 0, InStr(1, uProcess.szExeFile, Chr$(0)) - 1, 0))
Loop


CloseHandle hSnapShot

End Sub



Private Sub UserForm_Initialize()

' Call the Function

Load_Process_To_ListBox

End Sub

Companies House

Duport provide company formation, company credit reports and director reports.

Run a VB6.0 Executable from Excel/Word

Run an Executable from Excel VBA / Word VBA

If you need to use some grid for showing data / use the feautres in Visual Basic 6.0 that arenot available in VBA, you can create the application in VB6.0 or anyother program and show the User Interface in VBA code


Sub Run_VB6App_FromWord()

--- Some VBA Code here

sCmd = "C:\Program Files\MyFile.exe"
vntResult = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(sCmd, 1))
GetExitCodeProcess vntResult, lngExitCode

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

Do
GetExitCodeProcess vntResult, lngExitCode
DoEvents
Loop While lngExitCode = STILL_ACTIVE

--- some more VBA Code

End Sub


The above program will show the MyFile executable till the user clicks OK/Cancel. Once the application is closed the control will return to the calling VBA program

This used WinAPI Functions

Public Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long

Now it depends on how you use the external application. The most often used scenario will be to store the output from the called application (External App) to Registry or Database

VBA Read Text Files (With Leading & Trailing Spaces)

Read Data frm Text Files (VBA)


Reading Text Files using VBA is one of the major development activity of programmers. There are multiple ways to read a file

1. Input # Statement
2. Input Function
3. Get Function
4. File System Object Functions


Input # Statement

Dim MyString, MyNumber
Open "c:\test.txt" For Input As #1 ' Open file for input.
Do While Not EOF(1) ' Loop until end of file.
Input #1, MyString, MyNumber ' Read data into two variables.
Debug.Print MyString, MyNumber ' Print data to the Immediate window.
Loop
Close #1 ' Close file.

However, the bug here is Input # does not take the leading or trailing spaces with it. That is, ' My Name is ' becomes 'My Name is'. This will not be the correct one as we need to get the spaces also

Then Input function comes handy

Dim MyChar
Open "c:\test.txt" For Input As #1    ' Open file.
Do While Not EOF(1)    ' Loop until end of file.
  MyChar = Input(1, #1)    ' Get one character.
  Debug.Print MyChar    ' Print to the Immediate window.
Loop
Close #1    ' Close file.

However, the bug here will be the input that one needs - the number of characters to be extracted.

The obvious option is File system object


Sub Read_text_File()

Dim oFSO As New FileSystemObject
Dim oFS


Set oFS = oFSO.OpenTextFile("c:\textfile.TXT")

Do Until oFS.AtEndOfStream
sText = oFS.ReadLine
Loop


End Sub

This will read line-by line. all you need to add the Microsoft Scripting Runtime in the reference

Happy reading files:)

Extract Procedure Names from all Modules - VBA

Count No of Programs in a Workbook

Workbooks have Macros, If you need to know if the Workbook contains macros and then the following proc will get you the macros in the workbook

Sub Extract_Program()

Dim VBP As VBProject
Dim VBModule As CodeModule
Dim VBProc As VBComponent
Dim sLastProcName As String
Dim arProcName() As String
Dim iProcCount As Integer

Set VBP = ThisWorkbook.VBProject

For Each VBM In VBP.VBComponents

Set VBModule = VBM.CodeModule

i = 1
Do Until i >= VBModule.CountOfLines

procname = VBModule.ProcOfLine(i, vbext_pk_Proc)
i = i + 1
If LenB(procname) <> 0 Then
If procname <> sLastProcName Then
iProcCount = iProcCount + 1
ReDim Preserve arProcName(iProcCount)
arProcName(iProcCount) = procname
sLastProcName = procname
End If
End If
Loop
Next

' List all procedures
For i = 1 To UBound(arProcName)
MsgBox arProcName(i)
Next i
End Sub

ColorIndex - Coloring Excel Sheet Cells

Highlight Color in Excel Cells

Colorindex is used to color the background of Excel Cells

Cells(1, 2).Interior.ColorIndex = 30

etc

Here is the entire list of colors you can use:






RSS Feeds Submission Directory

Excel VBA - Delete Empty Rows

Delete Rows without Values

Here is a primitive simple function to delete rows that does not contain any value (I have taken Cols 1 to 10) for consideration.

Sub Delete_UnWanted_Rows()

For Each SHT In Sheets
SHT.Activate
iMax = SHT.Cells.SpecialCells(xlCellTypeLastCell).Row
For i2 = 2 To iMax
For i1 = 1 To 10
If LenB(SHT.Cells(i2, i1)) <> 0 Then
GoTo TakeNextRow
End If
Next i1
SHT.Rows(i2).EntireRow.Delete
TakeNextRow:
Application.StatusBar = SHT.Name & " " & i2
Next i2
TakeNextSht:

Next SHT
Application.StatusBar = False
End Sub

You can do the same with Special Cells - LastCell also

Setting Default & Cancel Buttons in VBA/Visual Basic

VB/ VBA Setting Default & Cancel Buttons through code

Private Sub Form_Load()

'Sets cmdOK as the button control that is clicked when the user presses the Enter key.
cmdOK.Default = True

'Sets cmdCancel as the button control that is clicked when the user presses the ESC key.
cmdCancel.Cancel = True

End Sub

For doing the same in VB.Net Refer : http://dotnetdud.blogspot.com/2007/06/vbnet-setting-default-cancel-buttons.html

Assigning Shortcut Keys - Excel Macros

Shortcut Key Assignment for Subroutines


It is always nice to have keyboard shortcuts for executing functions/subroutines rather than having to click the menu and its command

One way will to link the macro to a command button and assign the shortcut for the button. The other one is to assign the shortcut to the function using Application.OnKey

OnKey method executes a specified procedure when a particular key or key combination is pressed

Application.OnKey "%b", "ToWord"

is used to trigger the "ToWord" subroutine whenever Alt+b is pressed . Percentage symbol is used to substitute Alt key

Use the Caret (^) to symbol for Ctrl key and plus (+) for Shiftkey

Application.OnKey "^b", "ToWord"

Is for Ctrl + b

Other keys are :

Key	Code
BACKSPACE	{BACKSPACE} or {BS}
BREAK	{BREAK}
CAPS LOCK	{CAPSLOCK}
CLEAR	{CLEAR}
DELETE or DEL	{DELETE} or {DEL}
DOWN ARROW	{DOWN}
END	{END}
ENTER (numeric keypad)	{ENTER}
ENTER	~ (tilde)
ESC	{ESCAPE} or {ESC}
HELP	{HELP}
HOME	{HOME}
INS	{INSERT}
LEFT ARROW	{LEFT}
NUM LOCK	{NUMLOCK}
PAGE DOWN	{PGDN}
PAGE UP	{PGUP}
RETURN	{RETURN}
RIGHT ARROW	{RIGHT}
SCROLL LOCK	{SCROLLLOCK}
TAB	{TAB}
UP ARROW	{UP}
F1 through F15	{F1} through {F15}

To deassign/release the shortcut leave the Procedure empty

Application.OnKey "%b", ""


Disable Save (Ctrl S)

Application.OnKey "^s", ""

Using Function Keys in Visual Basic Forms

Function keys as Shortcut Keys in VB
Function keys are a boon for assigning shortcuts. They have more advantage than the regular Alt + or Ctrl + combination.

Function keys can be assigned to command buttons using simple tricks as explained below. For that we need to instuct the VB to handle them in the Keydown event by setting the Keypreview = True




Then you can have the necessary shortcut keys on the form



In the Form_KeyDown event redirect to necessary functions/procs based on the key

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

Select Case KeyCode

Case vbKeyF2

Call Proc_Fund_Transfer

Case vbKeyF3

Call Proc_Credit_Card


End Select

End Sub

Save copy of the workbook

Sub Saving_A_Copy_Of_Workbook()

'Saves a copy of the workbook to a file but doesn't modify the open workbook in memory

Dim bAchievedTarget As Boolean

If bAchievedTarget = True Then
ActiveWorkbook.SaveCopyAs "c:\Completed\FinalCopy.xls"
End If

' This function can be used to take the copy of the file while working on it. The current file remains the same however

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

Save RTF document as word

Print Multiple Sheets using VBA

'VBA to Select Multiple Sheets
Sub Print_Selected_Sheets()

' Remove Multiple Selections
ActiveWorkbook.Sheets(1).Select

' Select Multiple Sheets - Optional False is to extend the current selection to include any previously selected objects and the specified object
ActiveWorkbook.Sheets(1).Select False
ActiveWorkbook.Sheets(2).Select False
ActiveWorkbook.Sheets(4).Select False

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


ActiveWindow.SelectedSheets.PrintOut Copies:=1

' Remove Multiple Selections
ActiveWorkbook.Sheets(1).Select

End Sub

VBA Dir Function to Get Sub Directories

Get Sub Directories using VBA Dir Function

The below function is used to get the immediate sub-directories for a given directory. If you want to dig deep into the directory structure then you need to iterate the sub-directories as well

Sub Get_All_SubDirectories()

Dim arSubDir() As String
Dim sSubDir As String

sSubDir = GetSubDir("d:\trash\")

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

If LenB(sSubDir) <> 0 Then
arSubDir = Split(sSubDir, ";")
For i1 = 0 To UBound(arSubDir)
Debug.Print arSubDir(i1)
Next i1
End If

End Sub


Function GetSubDir(ByVal sPath As String, Optional ByVal sPattern As Variant) As Variant

Dim sDir As String
Dim sDirLocationForText As String

On Error GoTo Err_Clk

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

If IsMissing(sPattern) Then
sDir = Dir$(sPath, vbDirectory)
Else
sDir = Dir$(sPath & sPattern, vbDirectory)
End If
' -----------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
' -----------------------------------------------------------

Do Until LenB(sDir) = 0

' -----------------------------------------------------
' This will be the location for the sub directory
' -----------------------------------------------------
If sDir <> "." And sDir <> ".." Then
sDirLocationForText = sDirLocationForText & ";" & sPath & sDir
End If
sDir = Dir$

Loop

If Left$(sDirLocationForText, 1) = ";" Then sDirLocationForText = Right(sDirLocationForText, Len(sDirLocationForText) - 1)
GetSubDir = sDirLocationForText

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

Insert Procedure to a Module Using VBComponents

Insert Procedure to a Module Using VBComponents

Sub Insert_PRocedure_To_BasModule()

' This program will need reference to Microsoft Visual Basic for Extensibility Library

Dim VBP As VBProject
Dim VBC As VBComponent
Dim VBMod As CodeModule

' -----------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
' -----------------------------------------------------------
Workbooks.Add
Set VBP = ActiveWorkbook.VBProject

Set VBC = VBP.VBComponents.Add(vbext_ct_StdModule)
VBC.Name = "MyMacro"

Set VBMod = VBC.CodeModule

VBMod.InsertLines 3, "Sub NewProc()" & Chr(13) & _
" Msgbox ""Welcome to VB Component Programming"" " & Chr(13) & _
"End Sub"

End Sub

Dynamic Insertion of Procedure Bas Module, Dynamic Creation of Function / Procedure in BAS/Class Module, Automatic Creation of Function / Procedure in BAS/Class Module, Create New Module using VBA, VBA Create Module, VBA Attach Module to Workbook

Delete Module on the Fly using VBA

VBA Delete Bas Module / Class Modules


Sub Delete_BasModule_To_WorkBook()

' This program will need reference to Microsoft Visual Basic for Extensibility Library

Dim VBP As VBProject
Dim VBC As VBComponent
Dim VBMod As CodeModule

' -----------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
' -----------------------------------------------------------
Set VBP = ActiveWorkbook.VBProject

Set VBC = VBP.VBComponents("MyMacro")

' Delete the module
ActiveWorkbook.VBProject.VBComponents.Remove VBC

End Sub

Dynamic Deletion of Bas Module, Dynamic Deletion of Bas Module, Automatic Deletion of Bas Module, Delete Module using VBA, VBA Delete Module, VBA Detach Module to Workbook

Insert User Form on the Fly

Automatic Creation of User Form


Sub Insert_Form_To_WorkBook()

' This program will need reference to Microsoft Visual Basic for Extensibility Library

Dim VBP As VBProject
Dim VBC As VBComponent
Dim VBMod As CodeModule

' -----------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
' -----------------------------------------------------------
Workbooks.Add
Set VBP = ActiveWorkbook.VBProject

Set VBC = VBP.VBComponents.Add(vbext_ct_MSForm)
VBC.Name = "frmMyForm"

End Sub


Dynamic Insertion of User Form, Dynamic Creation of User Form, Automatic Creation of User Form, Dynamically Create New User Form using VBA, VBA Create Module, VBA Attach Module to Workbook

Insert Class Module on the Fly

Dynamic Insertion of Class Module


Sub Insert_Class_Module_To_WorkBook()

' This program will need reference to Microsoft Visual Basic for Extensibility Library

Dim VBP As VBProject
Dim VBC As VBComponent
Dim VBMod As CodeModule

' -----------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
' -----------------------------------------------------------
Workbooks.Add
Set VBP = ActiveWorkbook.VBProject

Set VBC = VBP.VBComponents.Add(vbext_ct_ClassModule)
VBC.Name = "clsMyClass"

End Sub


Dynamic Insertion of Class Module, Dynamic Creation of Class Module, Automatic Creation of Class Module, Create New Module using VBA, VBA Create Module, VBA Attach Module to Workbook

Insert Module on the Fly

Dynamic Insertion of Bas Module using VBComponents

Many a times we need to create Workbook through program and add some code to the workbook. If the both workbook and code are standard and do not change, we could use some template. On the other hand, if your requirement has constantly changing workbook and a relatively unstable code you can't use templates.

You need to rely on the VBComponent programming to dynamically create the Module in the Workbook

Sub Insert_BasModule_To_WorkBook()

' This program will need reference to Microsoft Visual Basic for Extensibility Library

Dim VBP As VBProject
Dim VBC As VBComponent
Dim VBMod As CodeModule

' -----------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
' -----------------------------------------------------------
Workbooks.Add
Set VBP = ActiveWorkbook.VBProject

Set VBC = VBP.VBComponents.Add(vbext_ct_StdModule)
VBC.Name = "MyMacro"

End Sub

Dynamic Insertion of Bas Module, Dynamic Creation of Bas Module, Automatic Creation of Bas Module, Create New Module using VBA, VBA Create Module, VBA Attach Module to Workbook

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