Convert a number to a date using VBA

This VBA procedure converts a number, in yyyymmdd format, to a regular date like mm/dd/yyyy.  For example, a number like 20090427 will get converted to 4/27/2009.





Public Function formatdatefromnumber(dateNumber)
On Error GoTo err_formatdatefromnumber

    Dim fmtYear, fmtMonth, fmtDay As String
        If IsNull(dateNumber) Then
            formatdatefromnumber = vbNullString
            Exit Function
            
        End If
        
        If Len(CStr(dateNumber)) <> 8 Then
            formatdatefromnumber = vbNullString
            Exit Function
        End If
        If Not IsNumeric(dateNumber) Then
            formatdatefromnumber = vbNullString
            Exit Function
        End If
        fmtYear = Mid(dateNumber, 1, 4)
        fmtMonth = Mid(dateNumber, 5, 2)
        
        If CInt(fmtMonth) > 12 Then
        formatdatefromnumber = vbNullString
        Exit Function
        End If
        fmtDay = Mid(dateNumber, 7, 2)
        If CInt(fmtDay) > 31 Then
        formatdatefromnumber = vbNullString
        Exit Function
        End If
        formatdatefromnumber = Format(DateSerial(fmtYear, fmtMonth, fmtDay), "mm/dd/yyyy")
        Exit Function

err_formatdatefromnumber:
MsgBox Err.Number & " " & Err.Description, vbCritical, "DateFromNumber()"
err_formatdatefromnumber = vbNullString
Exit Function
        
End Function

Disable Keyboard in VBA Code

Sub KeyboardOff()

   Application.DataEntryMode = True
End Sub

Disable Right Click When A Sheet Is Active

VBA Code for disable right click when a sheet is active:


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

Using Switch Function in VBA

Sub Exercise()
    Dim Status As Integer, EmploymentStatus As String
    Status = 1
    EmploymentStatus = "Unknown"
    'In the first argument, pass a Boolean expression
    'that can be evaluated to True or False. If that condition
    'is true, the second argument would be executed.
    EmploymentStatus = Switch(Status = 1, "Part Time")
    MsgBox ("Employment Status: " & EmploymentStatus)
End Sub

Convert No.to Text (Upto 10 crore) using VBA

Function spellnumber(ByVal num)

Dim decimalplace, count As Integer
ReDim Place(9) As String
    Place(2) = " Thousand "
    Place(3) = " Lakh"
    Place(4) = " Crore"
    Place(5) = " Trillion "
    decimalplace = InStr(num, ".")
 
 
num = Trim(Str(num))
    If decimalplace > 0 Then
    'extracting value after decimal
            
        Cents = getTens(Left(Mid(num, (decimalplace + 1), 2) & "00", 2))
     
    'extracting  remaining value before decimal
        num = Trim(Left(num, decimalplace - 1))
     
     
    End If
    count = 1
 
    Do Until Len(num) = 0
     
    If count = 1 Then
 
         
            Temp = getHundreds(Right(num, 3), count)
         
            num = Left(num, Len(num) - 3)
         
         
    ElseIf count > 1 Then
         
         
             
            'remaining no. is of two digits
            If Len(num) = 2 Then
         
                num = Right(num, Len(num))
                Temp = getHundreds(num, count)
                num = vbNullString
            'remaining no. is of one digit
            ElseIf Len(num) = 1 Then
                num = Right(num, Len(num))
                Temp = getHundreds(num, count)
                num = vbNullString
            'remaining no. is of more than one digit
            ElseIf Len(num) > 2 Then
                             
                Temp = getHundreds(Right(num, 2), count)
                num = Left(num, Len(num) - 2)
             
            End If
         
       
    End If
 
        If Temp <> "" Then Dollars = Temp & Place(count) & Dollars
     
     
     count = count + 1
           
     
     
    Loop
 
        Select Case Dollars
            Case ""
                Dollars = "No Rupees"
            Case "One"
                Dollars = "One Rupees"
            Case Else
                Dollars = Dollars & " Rupees"
        End Select

        Select Case Cents
            Case ""
                Cents = " and No Paisa"
            Case "One"
                Cents = " and One Paisa"
            Case Else
            Cents = " and " & Cents & "Paisa"
        End Select
 
 
spellnumber = Dollars & Cents
End Function




Function getTens(tenstext)

Dim result As String
result = vbNullString

    If Val(Left(tenstext, 1)) = 1 Then
        Select Case Val(tenstext)
            Case 10: result = "Ten"
            Case 11: result = "Eleven"
            Case 12: result = "Twelve"
            Case 13: result = "Thirteen"
            Case 14: result = "Fourteen"
            Case 15: result = "Fifteen"
            Case 16: result = "Sisxteen"
            Case 17: result = "Seventeen"
            Case 18: result = "Eighteen"
            Case 19: result = "Ninteen"
            Case Else
        End Select
    Else
        Select Case Val(Left(tenstext, 1))
            Case 2: result = "Twenty"
            Case 3: result = "Thirty"
            Case 4: result = "Fourty"
            Case 5: result = "Fifty"
            Case 6: result = "Sixty"
            Case 7: result = "Seventy"
            Case 8: result = "Eighty"
            Case 9: result = "Ninety"
            Case Else
        End Select
        result = result & getDigit(Right(tenstext, 1))
        'result = result
    End If
    getTens = result
End Function

Function getDigit(digit)
    Select Case Val(digit)
        Case 1: getDigit = "One"
        Case 2: getDigit = "Two"
        Case 3: getDigit = "Three"
        Case 4: getDigit = "Four"
        Case 5: getDigit = "Five"
        Case 6: getDigit = "Six"
        Case 7: getDigit = "Seven"
        Case 8: getDigit = "Eight"
        Case 9: getDigit = "Nine"
        Case Else: getDigit = ""
    End Select
End Function

Function getHundreds(ByVal number, ByVal count)
 
    Dim result As String
 
 
    If Val(number) = 0 Then Exit Function
    'Extracting last three no. of digit
    number = Right(number, Len(number))
 
    If Len(number) = 3 Then
 
        If Mid(number, 1, 1) <> "0" Then
               result = getDigit(Mid(number, 1, 1)) & "Hundred"
 
        End If
        If Mid(number, 2, 2) <> "0" Then
 
            result = result & getTens(Mid(number, 2, 2))
        End If
     
    ElseIf (Len(number) = 2 And (count = 2)) Then
            result = getTens(number) & result
       
    ElseIf (Len(number) = 1 And (count = 2)) Then
            result = getDigit(number) & result
         
    ElseIf (Len(number) = 2) And (count = 3) Then
            result = getTens(number) & result
         
    ElseIf (Len(number) = 1) And (count = 3) Then
            result = getDigit(number) & result
    ElseIf (Len(number) = 1) And (count = 4) Then
            result = getDigit(number) & result
    ElseIf (Len(number) = 2) And (count = 4) Then
            result = getTens(number) & result
         

    End If
    getHundreds = result & getDigit(Right(tenstext, 1))
End Function

Extract particular text from Hyperlink

For example we have a website http://www.amazon.com/Best-Sellers-Books-Architectural-Art-Design/zgbs/books/5005940011/ref=zg_bs_nav_b_2_1 linked to a cell hyperlink in an excel data. From where we need to extract only  5005940011. VBA code for this objective is as follows:


Dim myurl As String
Dim tempval, tempvalnew, nodeid As String

Sub searchVal()

myurl = ActiveCell.Hyperlinks(1).Address


For x = 1 To Len(myurl)
tempval = Mid(myurl, x, 1)

    If InStr(tempval, "/") <> 0 Then
    counter = counter + 1
 
    End If
    If (counter = 6 And tempval <> "/") Then
     
        nodeid = nodeid & tempval
     
    ElseIf counter = 7 Then
    ActiveCell.Offset(0, 1).Value = nodeid
    nodeid = vbNullString
    myurl = vbNullString
        Exit Sub

    End If
 
Next x



End Sub

Timer in Excel using VBA

Public Sub TestTimer()
MsgBox "The timer will switch off in 10 seconds!"
MsgBox ("Currenttime: " & Now)
alertTime = Now + TimeValue("00:00:10")
Application.OnTime alertTime, "TestTimer"
myMacro
End Sub

Determine a Cell in Specified Range or Not

Double click any sheet in VBA Project Explorer and paste following code:

Private Sub Worksheet_SelectionChange(ByVal target As Range)
If Not Intersect(target, Range("myrange")) Is Nothing Then
MsgBox target.Address & "is in myrange"
Else
MsgBox target.Address & "is not in myrange"
End If
End Sub

Move data from Row to Column

When there is a huge data in a single column; we may need to migrate some data to next column using page break. VBA code for this utility:

Option Explicit
Dim sht As Worksheet, myrng As Range, myrng1 As Range, count As Integer, i As Long
Dim myrng2 As Range, rowcount As Long
Sub moveRowtoColumn()
On Error Resume Next
Set sht = ThisWorkbook.Sheets(1)
Set myrng = sht.UsedRange.Columns(1)
count = sht.HPageBreaks.count
i = 0

For i = 1 To count
 
    Set myrng1 = sht.HPageBreaks(i).Location
    Set myrng2 = sht.HPageBreaks(i + 1).Location.Offset(-1, 0)
        If myrng2 Is Nothing Then
            Range(myrng1, myrng.Cells(65500, 1).End(xlUp)).Copy Destination:=sht.Cells(1, i + 1)
        Else
            Range(myrng1, myrng2).Copy Destination:=sht.Cells(1, i + 1)
        End If
     
    Set myrng1 = Nothing
    Set myrng2 = Nothing
Next

sht.Range(sht.HPageBreaks(1).Location.Address, myrng.Cells(65500, 1).End(xlUp).Address).Delete
    Set myrng = Nothing
End Sub

Excel VBA LogTracker

VBA code for generating Excel Log tracker

In module:

Sub eLoggerInfo(Evnt As String)
Application.ScreenUpdating = False
Dim counter As Long
    cSheet = ActiveSheet.Name
        If sheetExists("LoggerInfo") = False Then
            Sheets.Add.Name = "LoggerInfo"
            Sheets("LoggerInfo").Select
            'ActiveSheet.Protect "Pswd", userinterfaceonly:=True
        End If
        Sheets("LoggerInfo").Visible = True
        Sheets("LoggerInfo").Select
        'ActiveSheet.Protect "Pswd", userinterfaceonly:=True
' assigning value to counter
        counter = Range("A1")
       
        If counter <= 2 Then
            counter = 3
            Range("A2").Value = "Event"
            Range("B2").Value = "User Name"
            Range("C2").Value = "Domain"
            Range("D2").Value = "Computer"
            Range("E2").Value = "Date and Time"
        End If
        'fixing event length to 25
        If Len(Evnt) < 25 Then Evnt = Application.Rept(" ", 25 - Len(Evnt)) & Evnt
   
            Range("A" & counter).Value = Evnt
            Range("B" & counter).Value = Environ("UserName")
            Range("C" & counter).Value = Environ("USERDOMAIN")
            Range("D" & counter).Value = Environ("COMPUTERNAME")
            Range("E" & counter).Value = Now()
            counter = counter + 1
          'Deleting  records if no. of records are more than 20000
            If counter > 20002 Then
                Range("A3:A5002").Select
                dRows = Selection.Rows.Count
                Selection.EntireRow.Delete
                counter = counter - dRows
            End If
            Range("A1") = counter
            Columns.AutoFit
            Sheets(cSheet).Select
            Sheets("LoggerInfo").Visible = xlVeryHidden
            Application.ScreenUpdating = True
       
End Sub

Function sheetExists(sheetName As String) As Boolean
On Error GoTo SheetDoesnotExit
    If Len(Sheets(sheetName).Name) > 0 Then
        sheetExists = True
        Exit Function
    End If
SheetDoesnotExit:
        sheetExists = False
End Function
Sub ViewLoggerInfo()
    Sheets("LoggerInfo").Visible = True
    Sheets("LoggerInfo").Select
End Sub
Sub HideLoggerInfo()
    Sheets("LoggerInfo").Visible = xlVeryHidden
End Sub

In Thisworkbook module:

Private Sub workbook_beforeprint(cancel As Boolean)
Dim Evnt As String
Evnt = "Print"
Call eLoggerInfo(Evnt)
End Sub


Private Sub workbook_beforesave(ByVal saveasUI As Boolean, cancel As Boolean)
    Dim Evnt As String
    Evnt = "Save"
    Call eLoggerInfo(Evnt)

End Sub

Private Sub workbook_Open()
    Dim Evnt As String
    Evnt = "Open"
    Call eLoggerInfo(Evnt)

End Sub

Floating Button in VBA

VBA code for creating floating button in excel sheet:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If (Target.Column < 2 And Target.Row < 2) Then Exit Sub
With ActiveSheet.Shapes("CommandButton1")
    .Top = Target.Offset(, 0).Top
    .Left = Target.Offset(, 0).Left
End With
End Sub

Build-up your Logic in VBA(Create Pyramid)

Sub test()
k = 1
c = 9
For i = 10 To 1 Step -1
For j = c To k Step -1

    Cells(i, j) = "*"
     
Next j
k = k + 1
c = c - 1
Next i

End Sub

Calculation of Net Working Days

Here is a small VBA code for calculating net working days excluding Sunday:




Option Explicit


'Date should of "dd-mmm" format in cells

Function clcnetworkingdays(startdate As Date, enddate As Date) As Variant
Dim daystaken As Integer
Dim cnt As Integer, tempCounter As Integer
daystaken = enddate - startdate

    For cnt = 1 To daystaken
        If WorksheetFunction.Text((startdate + cnt), "ddd") = "Sun" Then
            tempCounter = tempCounter + 1
         
         End If
 
    Next
    daystaken = daystaken - tempCounter
    clcnetworkingdays = daystaken
End Function

Add Hyperlink in Excel

We have to create a table of content in Excel worksheet where there will be a sheet hyper link for every data in TOC sheet except Header
VBA Code:





Sub toc()
Dim wkb As Workbook
Dim wks As Worksheet
Dim wkscount As Integer
Dim lp As Integer
Dim wkbname As String
Dim path As String
Set wkb = ActiveWorkbook
wkscount = wkb.Sheets.Count
Set wks = wkb.Sheets.Add(before:=wkb.Sheets(1))
wks.Name = "TOC"
ActiveSheet.Range("a1").Value = "Table of Content"
For lp = 2 To wkscount + 1
wkbname = wkb.Sheets(lp).Name
ActiveSheet.Range("a" & lp).Value = wkbname
path = "file:///" & wkb.path
MsgBox (ActiveCell.Offset((lp - 1), 0).Address)
'Range("A" & lp).Select
'MsgBox (path)
ActiveCell.Offset((lp - 1), 0).Hyperlinks.Add Anchor:=ActiveCell.Offset((lp - 1), 0), Address:="", SubAddress:= _
        ActiveCell.Offset((lp - 1), 0).Value & "!A1", TextToDisplay:=wkbname


'MsgBox wkscount

Next lp

End Sub

Sample code for BeforeRightClick Event

Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)

Dim cBar As CommandBar
Dim cmdCon1 As CommandBarControl
Dim cmdCon2 As CommandBarControl

'Prevent the standard popup showing
 Cancel = True

'We must delete the old one first
On Error Resume Next
Application.CommandBars("Ozgrid").Delete

    'Add a CommandBar and set the CommandBar _
     variable to a new popup
     Set cBar = Application.CommandBars.Add _
     (Name:="Ozgrid", Position:=msoBarPopup)

    'Add a control and set our 1st CommandBarControl _
     variable to a new control
     Set cmdCon1 = cBar.Controls.Add
    'Add some text and assign the Control
    With cmdCon1
        .Caption = "I'm a custom control"
        .OnAction = "MyMacro" 'calling macro from Module
    End With

    'Add a control and set our 2nd CommandBarControl _
     variable to a new control
     Set cmdCon2 = cBar.Controls.Add
    'Add some text and assign the Control
    With cmdCon2
        .Caption = "Somu's Macro"
        .OnAction = "AnotherMacro"
    End With

cBar.ShowPopup
End Sub

Dynamic Display of Image in Excel

Insert images in  second sheet of Excel with specified range

Create a name range ‘getChart()’ with formula

=IF(Sheet1!$A$1="pic1",Sheet2!$A$1:$C$9,IF(Sheet1!$A$1="pic2",Sheet2!$A$10:$C$18, IF(Sheet1!$A$1="pic3",Sheet2!$A$19:$C$27,"")))

Draw a drop down list in sheet1 mentioning all three  pics  name

Below draw a range with Camera from a quick access tool bar.

Insert an image in that range and click on that image and insert  =getchart formula bar

Class Module Sample Code

Classes are Objects which allow you to group a set of related functionality into one group.The advantage of using classes instead of just subroutines is that classes create a level of abstraction that allow you to write cleaner code. One key indication that you should switch to classes is if you're constantly adding parameters to your functions and subroutines.

A Class can contain:

·        Subs and Functions – generally called Class Methods

       Properties – you can Get and Let these (or Set them if they are Objects)

The Get procedure is used to return a value out of the class, and the Let procedure is to put a value into the class. Note that the return data type of the Get property procedure must be the same data type as the (last) parameter to the Let property procedure. Otherwise, you'll get a compiler error. 

       Events – can be fired

       A Constructor and a Destructor – called Class_Initialize and Class_Terminate.They are called automatically when a Class object is instantiated and destroyed, respectively. You don‘t need to call these Methods; they are called automatically by VBA

       Public Member Variables – can be accessed from outside the class – generally considered bad Object Oriented Design – use Properties instead

       Private Member Variables – can only be accessed inside the class

Sample Code for an Excel VBA Classes:

In the VBA editor, go to Insert > Class Module. In the Properties window (bottom left of the screen by default), change the name of the module to WorkLogItem. Add the following code to the class:

Option Explicit

Private pTaskID As Long
Private pPersonName As String
Private pHoursWorked As Double

Public Property Get TaskID() As Long
    TaskID = pTaskID
End Property

Public Property Let TaskID(lTaskID As Long)
    pTaskID = lTaskID
End Property

Public Property Get PersonName() As String
    PersonName = pPersonName
End Property

Public Property Let PersonName(lPersonName As String)
    pPersonName = lPersonName
End Property

Public Property Get HoursWorked() As Double
    HoursWorked = pHoursWorked
End Property

Public Property Let HoursWorked(lHoursWorked As Double)
    pHoursWorked = lHoursWorked
End Property

Let's keep moving with this example. Instead of storing the objects in array, we'll try using acollection.

Next, add a new class module and call it ProcessWorkLog. Put the following code in there:

Option Explicit

Private pWorkLogItems As Collection

Public Property Get WorkLogItems() As Collection
    Set WorkLogItems = pWorkLogItems
End Property

Public Property Set WorkLogItems(lWorkLogItem As Collection)
    Set pWorkLogItems = lWorkLogItem
End Property

Function GetHoursWorked(strPersonName As String) As Double
    On Error GoTo Handle_Errors
    Dim wli As WorkLogItem
    Dim doubleTotal As Double
    doubleTotal = 0
    For Each wli In WorkLogItems
        If strPersonName = wli.PersonName Then
            doubleTotal = doubleTotal + wli.HoursWorked
        End If
    Next wli

Exit_Here:
    GetHoursWorked = doubleTotal
        Exit Function

Handle_Errors:
        'You will probably want to catch the error that will '
        'occur if WorkLogItems has not been set '
        Resume Exit_Here


End Function

The above class is going to be used to "do something" with a colleciton of WorkLogItem. Initially, we just set it up to count the total number of hours worked. Let's test the code we wrote. Create a new Module (not a class module this time; just a "regular" module). Paste the following code in the module:

Option Explicit

Function PopulateArray() As Collection
    Dim clnWlis As Collection
    Dim wli As WorkLogItem
    'Put some data in the collection'
    Set clnWlis = New Collection

    Set wli = New WorkLogItem
    wli.TaskID = 1
    wli.PersonName = "Fred"
    wli.HoursWorked = 4.5
    clnWlis.Add wli

    Set wli = New WorkLogItem
    wli.TaskID = 2
    wli.PersonName = "Sally"
    wli.HoursWorked = 3
    clnWlis.Add wli

    Set wli = New WorkLogItem
    wli.TaskID = 3
    wli.PersonName = "Fred"
    wli.HoursWorked = 2.5
    clnWlis.Add wli

    Set PopulateArray = clnWlis
End Function

Sub TestGetHoursWorked()
    Dim pwl As ProcessWorkLog
    Dim arrWli() As WorkLogItem
    Set pwl = New ProcessWorkLog
    Set pwl.WorkLogItems = PopulateArray()
    Debug.Print pwl.GetHoursWorked("Fred")

End Sub

Why is this helpful?

Let's suppose your data changes and you want to add a new method. Suppose your WorkLogItemnow includes a field for HoursOnBreak and you want to add a new method to calculate that.

All you need to do is add a property to WorkLogItem like so:

Private pHoursOnBreak As Double

Public Property Get HoursOnBreak() As Double
    HoursOnBreak = pHoursOnBreak
End Property

Public Property Let HoursOnBreak(lHoursOnBreak As Double)
    pHoursOnBreak = lHoursOnBreak
End Property

Pop-up calendar using Active X Control

Open the file Personal.xls

    Then Insert a Userform
    Then change properties of Userform with
    Name :frmCalendar
    Caption: Select a Date

Then go to View >Toolbox>Tools>Additional Controls and choose Calendar Control(Active X control)

Next add a command button.

Place the Command button on Userform.

Do the following changes in properties window
Name: cmdClose
Cancel: True


VBA code for Commandbutton:

    private sub cmdClose_Click()

        Unload Me

    End sub

VBA code for Calendar control



    Private sub Calendar1_Click()

    Activecell.value=Calendar1.value
    Unload me
   

End sub


Then Insert module and create a macro


    sub openCalendar()
        frmCalendar.Show
       
    End sub



In Personal.xls, click office button.Then click Excel Options.

Then choose Customised option.

Choose Macros from Command drop-down.

Add Macro Opencalendar() to quick access toolbar.

Then do double click on OK button.

VBA Code Casestudy:Automated V-lookup

In our office we have a huge database of sub-publisher group,we need to enter in excel worksheet and their corresponding publisher name. Here is a VBA code who matches sub-publisher from active workbook to Master data file of sub publisher's and give their corresponding publisher's name  in respective column
VBA code using v-lookup is as  mentioned below:



Function automatedVlookup()
    Dim pathname, vlookupformula, bookname, sheetname As String
    Dim displaycolumn As Integer
    Dim wb  As Workbook
    Dim mywb As String
 
    Dim myrng, displayrange, lookuprange  As Range
    Application.ScreenUpdating = False
    Dim cntrow, tempcount As Long
 
 
    On Error Resume Next
 
    'Selecting columnno. of Publisher name
 
 
     mywb = CStr(ActiveWorkbook.Name)
    'counting total no. of rows
     cntrow = ActiveWorkbook.Sheets(1).UsedRange.Rows.Count
 
    'selecting column of publisher subgroup
    Set myrng = Application.InputBox("Select column", "Sub publisher group", Type:=8)
    displaycolumn = CInt(Application.InputBox("Select column no. you want to display", "for Publisher group", Type:=2))
 
   
        pathname = frmfinal.temppathname.Value & "\pub group_new.xls"
     
        'openning publisher master file
     
        Set wb = Workbooks.Open(pathname)
       
        If Not wb Is Nothing Then
         
            Set lookuprange = wb.Sheets(1).UsedRange
            bookname = "pub group_new.xls"
            sheetname = wb.Sheets(1).Name
     
        tempcount = 1
 
            Do
                    Set myrng = myrng.Offset(1, 0)
                    Set displayrange = myrng
         
                    'setting lookup formula
                    vlookupformula = "=if(iserror(vlookup(" & CStr(myrng.Address) & ",'[" & bookname & "]" & sheetname & "'!" & CStr(lookuprange.Address) & ",2,0))," & Chr(34) & Chr(34) & "," & "vlookup(" & CStr(myrng.Address) & ",'[" & bookname & "]" & sheetname & "'!" & CStr(lookuprange.Address) & ",2,0))"
             
             
                    'writing vlookup formula
         
                    displayrange.Offset(0, displaycolumn).Formula = vlookupformula
             
                    tempcount = tempcount + 1
            Loop Until tempcount = cntrow
        Else
     
            MsgBox "Publisher file Not found"
        End If
        wb.Close savechanges:=False
        Set wb = Nothing
        Unload frmfinal
        Application.ScreenUpdating = True
 

End Function

VBA Code for Google Search Engine

Automatic Openning of Google Search Engine through VBA Code:



Option Explicit
Sub googleSearch()
Dim browser As New InternetExplorer
Dim htmldoc As HTMLDocument
Dim url As String
Dim i, j As Integer
Dim objcollection, objelement As Object

    Application.ScreenUpdating = False
    On Error GoTo Errorhandler
    url = "http://www.google.co.in"
    browser.navigate url
    browser.Visible = True
    MsgBox "Your data is being searched"
    MsgBox "Chck1"
    Set htmldoc = browser.document
    Set objcollection = htmldoc.getElementsByTagName("Input")
        MsgBox "Chck2"
        While i < objcollection.Length
                If objcollection(i).Name = "q" Then
                MsgBox "Chck3"
                    objcollection(i).Value = Range("A2").Value
           
                End If
                MsgBox "Chck4"
            i = i + 1
        Wend
    Set objcollection = Nothing
    Set objcollection = htmldoc.getElementsByTagName("button")
    MsgBox "Chck5"
        While j < objcollection.Length
            If objcollection(j).Type = "submit" Then
                    Set objelement = objcollection(j)
                    objelement.Click
            End If
         MsgBox "Chck6"
           j = j + 1
        Wend
        Set objelement = Nothing
        Set objcollection = Nothing
        Set htmldoc = Nothing
        Set browser = Nothing
        Application.ScreenUpdating = True
    Exit Sub
Errorhandler:
    MsgBox "Error" & Err.Description
End Sub

Creating Worksheet Calendar through VBA

VBA code for creating a Calendar in Excel Worksheet

Option Explicit

Sub createClaendar()

Dim lmonth, ldays As Long

Dim strmonth, straddress As String

Dim myrng, mycell As Range

Dim mydate As Date

    Application.ScreenUpdating = False

    On Error Resume Next

    'removing grid lines in excel sheet

    ActiveWindow.DisplayGridlines = False

    'Fixing cells size

    With Cells

        .ColumnWidth = 6

        .Font.Size = 8

    End With

    'Select quaterly month's name in row wise

    For lmonth = 1 To 4

        Select Case lmonth

            Case 1

                strmonth = "January"

                Set myrng = Range("A1")

            Case 2

                strmonth = "April"

                Set myrng = Range("A8")

            Case 3

                strmonth = "July"

                Set myrng = Range("A15")

            Case 4

                strmonth = "October"

                Set myrng = Range("A22")

        End Select

        'Entering month's name

        With myrng

            .Value = strmonth

            .Font.Bold = True

            .Interior.ColorIndex = 22

                With .Range("A1:G1")

                     .Merge

                     .BorderAround LineStyle:=xlContinuous

                End With

                'seleting months rowwise

            .Range("A1:G1").AutoFill Destination:=.Range("A1:U1")

        End With

        

        

    

      Next lmonth

      lmonth = 1

      For lmonth = 1 To 12

      straddress = Choose(lmonth, "A2:G7", "H2:N7", "O2:U7", "A9:G14", "H9:N14", "O9:U14", "A16:G21", "H16:N21", "O16:U21", _

                "A23:G28", "H23:N28", "O23:U28")

      ldays = 0

            For Each mycell In Range(straddress)

              ldays = ldays + 1

              mydate = DateSerial(Year(Date), lmonth, ldays)

                  If Month(mydate) = lmonth Then

                      'fill each month's range

                          With mycell

                             .Value = DateSerial(Year(Date), lmonth, ldays)

                             .NumberFormat = "ddd dd"

                          End With

                  End If

            Next mycell

      Next lmonth

    

End Sub

Convert Excel Sheet to HTML

Option Explicit
Sub converttoHtml()
Dim myrng As Range
Dim temppathname As String
Dim tempwb As Workbook
Set myrng = ActiveSheet.UsedRange
On Error Resume Next
Application.ScreenUpdating = False
temppathname = Environ("temp") & "/" & Format(Date, "mm-dd-yy") & ".htm"
myrng.Copy
Set tempwb = Workbooks.Add(1)
    With tempwb.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial.xlPasteFormats , , False, False
        ActiveWorkbook.Save
    End With
    With tempwb.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
         Filename:=temppathname, _
         Sheet:=tempwb.Sheets(1).Name, _
         Source:=tempwb.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set tempwb = Nothing
    Set myrng = Nothing
End Sub

Acces VBA Macro from another Excel File

If you want to access VBA Macro from another Excel file Code is as follows:




Option Explicit
Sub accessotherMacro()
Dim pathname As String
Application.ScreenUpdating = False
Dim wb As Workbook
On Error Resume Next
pathname = "C:\Users\abc\Desktop\mybook1.xls"
MsgBox Dir(pathname)
On Error Resume Next
        If Not Dir(pathname) = vbNullString Then
            Set wb = Workbooks.Open(pathname)
            Application.Run (wb.Name & "!test")
        ElseIf Dir(pathname) = vbNullString Then
            MsgBox "File doesnot Exist"
        End If
Application.ScreenUpdating = True




End Sub

Caculation of Age from DoB

It's a simple code for calculation of one's age in terms of year,monh and days





Sub calculateAge()
Dim mydob As Date, tempdob As Date, sysdate As Date
Dim y As Integer, m As Integer, d As Integer
mydob = CDate(Application.InputBox("Enter your DoB", "DoB", Default:=Format(Date, "mm/dd/yyyy"), Type:=2))
sysdate = Format(Date, "mm/dd/yyyy")
tempdate = DateSerial(Year(sysdate), Month(mydob), Day(mydob))
    If (tempdate > sysdate) Then
        y = (Year(tempdate) - Year(mydob)) - 1
        If Day(mydob) > Day(sysdate) Then
             m = -Month(mydob) - 12 * (tempdate > sysdate) + Month(sysdate) - 1
             sysdate = DateSerial(Year(sysdate), Month(sysdate), 0)
             d = Day(sysdate) - Day(mydob) + Day(Date)

        ElseIf Day(mydob) < Day(sysdate) Then
            m = -Month(mydob) - 12 * (tempdate > sysdate) + Month(sysdate)
            d = Day(Date) - Day(mydob)
     

        End If
     ElseIf (tempdate < sysdate) Then
            y = (Year(tempdate) - Year(mydob))
        If Day(mydob) > Day(sysdate) Then
             m = Month(Date) - Month(mydob) - 1
             sysdate = DateSerial(Year(sysdate), Month(sysdate), 0)
             d = Day(sysdate) - Day(mydob) + Day(Date)

        ElseIf Day(mydob) < Day(sysdate) Then
            m = -Month(mydob) - 12 * (tempdate > sysdate) + Month(sysdate)
            d = Day(Date) - Day(mydob)
     

        End If
    End If
   MsgBox "Your age  is" & y & " Years " & m & " months " & d & "days"
End Sub

Invoking Stored Procedure in VBA

I have created a stored procedure sp_displayspl_Members in MSSQL Server.
Code to create Stored procedure:
if exists(select * from sysobjects where name='sp_displayspl_Members')begindrop procedure sp_displayspl_Members;endgocreate procedure sp_displayspl_Members @membertype char(8)as
Select
Through this stored procedure we have selected records where Membertype='Social'

In order to open a stored procedure within ActiveX Data Objects (ADO), you must first open a Connection Object, then a Command Object, fill the Parameters Collection with one parameter in the collection for each parameter in the query, and then use the Command.Execute() method to open the ADO Recordset. VBA Code:


Sub callSP()
Dim con1 As New ADODB.Connection
Dim cmd1 As New ADODB.Command
Dim rs1 As New ADODB.Recordset
Dim reccounter As Long
Dim spcreate, spdrop As String
On Error GoTo Errorhandler
spdrop = "if exists(select * from sysobjects where name='sp_displayspl_Members') drop procedure sp_displayspl_Members"
spcreate = "create procedure sp_displayspl_Members @membertype char(8) as Select * from Member where Membertype=@membertype"
        con1.ConnectionString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;Data Source=NEW\SQLEXPRESS;"
        con1.Open
          
        Set rs1 = con1.Execute(spdrop)
        Set rs1 = Nothing
           
         Set rs1 = con1.Execute(spcreate)
        Set rs1 = Nothing
        
       
        cmd1.ActiveConnection = con1
        cmd1.CommandText = "sp_displayspl_Members"
        cmd1.CommandType = adCmdStoredProc
       
        cmd1.Parameters(1).Value = "Social"
       
        
        Set rs1 = cmd1.Execute()
       
        Do While Not rs1.EOF
        reccounter = reccounter + 1
               val1 = rs1(0)
               val2 = rs1(1)
               val3 = rs1(2)
               val4 = rs1(3)
               val5 = rs1(4)
               val6 = rs1(5)
               val7 = rs1(6)
               val8 = rs1(7)
                Cells(reccounter, 1) = val1
                Cells(reccounter, 2) = val2
                Cells(reccounter, 3) = val3
                Cells(reccounter, 4) = val4
                Cells(reccounter, 5) = val5
                Cells(reccounter, 6) = val6
                Cells(reccounter, 7) = val7
                Cells(reccounter, 8) = val8
                rs1.MoveNext
               
        Loop
        If rs1.State <> adStateClosed Then
                rs1.Close
                con1.Close
                Set rs1 = Nothing
                Set con1 = Nothing
         End If
Exit Sub
Errorhandler:
    MsgBox "Error description:" & Err.Description
End Sub * from Member where Membertype=@membertype

VBA Code for Chart Event

This event works for Chartsheet not for embedded chart.
VBA Code is mentioned below(for top 10 billionaire chart)




Dim chrt As Chart
Dim ser As Series
Dim chrtdata, chrtlbl, txtBox As Object, elementId As Long, arg1 As Long, arg2 As Long
Private Sub Chart_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
On Error Resume Next
Application.ScreenUpdating = False
Set chrt = ActiveChart
Set ser = ActiveChart.SeriesCollection(1)
chrtdata = ser.Values
chrtlbl = ser.XValues
txtBox.Delete
chrt.GetChartElement x, y, elementId, arg1, arg2
    If elementId = xlSeries Then
 
        Set txtBox = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, x - 135, y - 125, 100, 100)
        txtBox.Height = 56
        txtBox.Width = 80
        txtBox.Name = "Hover"
        txtBox.Fill.ForeColor.SchemeColor = 27
        txtBox.Line.DashStyle = msoLineSolid
        txtBox.TextFrame.Characters.Text = "Sales Amount: " & "$" & chrtdata(arg2) & Chr(10) & "Sales Person: " & chrtlbl(arg2)
        txtBox.TextFrame.Characters.Font.Size = 10
        txtBox.TextFrame.Characters.Font.ColorIndex = 1
        txtBox.TextFrame.Characters.Font.Bold = True
        ser.Points(arg2).Interior.ColorIndex = 38
     Else
        ser.Interior.ColorIndex = 18
    End If
End Sub

https://drive.google.com/file/d/0B23eJ2xd9ODyTTBXcjA2TjZmQzg/edit?usp=sharing

Import Excel Worksheet data to SQLServer

We have created a Dummy Database called Member into SQL Server with following paramater:

MemberIf int primary key, Firstname char(20)not null,Lastname char(20) not null,Phone char(20)not null,Handicap Int not null,Joindate Datetime not null,Gende char(1) not null, Membertype char(20) foreign key
Vba Code for Entering data from Excel worksheet:

Sub browseRecord()
Dim selrng, dataval As Range
Dim strsql As String
Dim MemberId, Handicap As Integer
Dim Firsname, Lastname, phone, JoinDate, Gender, MemberType As String
Dim cnn As New ADODB.Connection
On Error GoTo errorhandler
cnn.ConnectionString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;Data Source=NEW\SQLEXPRESS;"
cnn.Open

On Error Resume Next
Dim rowcount As Variant
Set dataval = Range("A1")
Set selrng = Range("A:A")
rowcount = WorksheetFunction.CountA(selrng)
        For i = 1 To rowcount
                 MemberId = CInt(dataval.Offset(i - 1, 0))
                 Firsname = dataval.Offset(i - 1, 1)
                 Lastname = dataval.Offset(i - 1, 2)
                 phone = dataval.Offset(i - 1, 3)
                 Handicap = CInt(dataval.Offset(i - 1, 4))
                 JoinDate = dataval.Offset(i - 1, 5)
                 Gender = dataval.Offset(i - 1, 6)
                 MemberType = dataval.Offset(i - 1, 7)
                
                 strsql = "Insert  into Member values( " & MemberId & ",' " & Trim(Firsname) & "'," & "'" & Trim(Lastname) & "','" & phone & "'," & Handicap & ",'" & JoinDate & "'," & "'" & Gender & "'," & "'" & Trim(MemberType) & "');"
                 cnn.Execute strsql
                 MsgBox strsql
        Next i
        cnn.Close
        Set cnn = Nothing
        Exit Sub
errorhandler:
        MsgBox "Error" & Err.Description
End Sub

                                 

Turn VBA code into Add-In

Turn Vba Code into excel Add-in
Find specific in all Worksheet

An Excel Add-In is a file (usually with an .xlam, .xla extension) that Excel can load when it starts up. The file contains
code (VBA in the case of an .xla/.Xlam Add-In) that adds additional functionality to Excel, usually in the form of new functions.

You can say it's a modified version of UDF which can be used across all worksheets.

How to crete an Add-In:

1.Open an excel file with normal VBA code which you want to convert an Add-In

2.Open Project properties Under General tab give a new name to the project.Under Protection tab, lock the project with new
  password.

3.In Save as Type drop-down list,select Excel Add-In(*.xlam/*.xla).

4.Click Save

A new Add-In file is created.

Installing Add-In
1. Press Alt TI in already opened excel file
2. Click Browse button and locate the Add-In file just created.
3. After adding new Add-In  in its list,click the check button of respective Add-In; it will be added in Add-In's list.
4. Don't save opened file.
5. Restart Excel

To distribute Add-In you just distribute the (*.Xlam/*.xla) file to respective user.


VBA code for calculating Age:




Function calcAge(dob As Date)
    If dob = 0 Then
        MsgBox "No Birthdate"
    Else
        Select Case Month(Date)
            Case Is < Month(dob)
                clacAge = Year(Date) - Year(dob) - 1
            Case Is = Month(dob)
                If Day(Date) >= Day(dob) Then
                    calcAge = Year(Date) - Year(dob)
                Else
                    calcAge = Year(Date) - Year(dob) - 1
                End If
            Case Is > Month(dob)
                calcAge = Year(Date) - Year(dob)
        End Select
    End If
End Function

Worksheet Change Event

The Change Event is triggered when any cell in a worksheet is changed by the user or by any VBA application. Worksheet change event receives a Range object as its target argument.

VVBA code for validating data entry:

Private Sub Worksheet_Change(ByVal target As Range)
Dim myrng As Range, cell As Range
On Error Resume Next
Set myrng = Range("ValidRange")
   For Each cell In Intersect(myrng, target)
       If cell.Value > 12 Or cell.Value < 1 Then
            MsgBox "Please enter a value between 1 and 12"
            Range(cell.Address).Select
       End If
   Next cell
    Application.EnableEvents = True
End Sub

Create Multiple Worksheet

Following VBA Code is an utility code for creating multiple worksheets  for a month on a daily basis:



Option Explicit

Sub createMultipleWorksheet()
Dim strdate As String
Dim numdays As Long, i As Long

Dim wsbase As Worksheet
On Error GoTo Errorhandler
    Do
        strdate = Application.InputBox("Please enter month and year:mm/yyyy", Title:="Month and year", Default:=Format(Date, "mm/yyyy"), Type:=2)
     
       If IsDate(strdate) Then Exit Do
       If MsgBox("Please enter a valid date such as ""01/2008"" " & vbLf & vbLf & "Shall we try again?", vbYesNo + vbExclamation, "Invalid date") = vbNo Then End
     
    Loop
    numdays = Day(DateSerial(Year(strdate), Month(strdate) + 1, 0))
 
    Set wsbase = Sheets("Sheet1")
    For i = 1 To numdays
        wsbase.Copy after:=Sheets(Sheets.Count)
        ActiveSheet.Name = Format(DateSerial(Year(strdate), Month(strdate), i), "mm.dd.yy")
    Next i
Exit Sub
Errorhandler:
MsgBox "Error" & Err.Description

End Sub

Extracting Data from Website to Excel

Sometimes we need to extract some stock price related info from website to Excel worksheet. Here is the VBA Code to extract info from Yahoo Finance:


Sub getInfoOnine()
Dim qt As QueryTable
Set qt = ActiveSheet.QueryTables.Add(Connection:="Url;http://finance.yahoo.com/q?s=infy", Destination:=Range("B2"))
With qt
        .Name = "Getting online data"
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingAll
        .WebTables = "1,2,3"
        .EnableRefresh = True
        .RefreshPeriod = 10
        .Refresh
End With
End Sub

Example Messagebox Function in VBA

It's a sample code for messagebox function in vba for excel spreadsheet

Sub diplaymessageBox()
Dim stranswer As VbMsgBoxResult
stranswer = MsgBox("Would you like to colour the cell?", vbQuestion + vbYesNo, "Select Option")
If stranswer = vbYes Then
        Selection.Interior.ColorIndex = 8
    End If
End Sub

Importing Txt file into Excel

VBA Code for importing a text file into excel spredaheet

Sub importFile()

Dim filepathName As String

filepathName = InputBox("Enter complete filepath name:")

    With ActiveSheet.QueryTables.Add(Connection:="text;" & filepathName, Destination:=Range("A1"))
        .Name = "Excel Importing Text File"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = True
        .TextFileColumnDataTypes = Array(1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
   
    End With

End Sub

Automated Search Option for Spreadsheet

Following VBA code is  an extension of existing Find function in  Excel Spreadsheet. Though normal Find

function you have to find desired data in each sheet seperately. Through below mentioned code you can get

the result of searched value across all cells of spreadsheets in an Excel Workbook. Wherever the code will

find the data, it will automatically bold , enlarge that cell and save the worksheet.


Sub searchthroughSheet()
Dim mydata As Variant
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Dim c As range
mydata = InputBox("Enter your value to search:")
On Error Resume Next
For Each ws In wb.Worksheets
With Worksheets(ws.Index).Cells
Sheets(ws.Index).Select
    Set c = .find(mydata, LookIn:=xlValues)
    If Not c Is Nothing Then
            firstaddress = c.Address
            Do
                MsgBox "Match found in" & Worksheets(ws.Index).Name & c.Address
                range(c.Address).Select
                Selection.Font.Bold = True
                Selection.Font.Size = 20
                ActiveWorkbook.Save
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstaddress
    End If
End With
Next ws
End Sub

Copy Specific Cells in a Worksheet by VBA

'VBA  Code to copy specified cells from all the files in a folder

Option Explicit
Dim objFso As Object, pathname As String, eachfile, objFolder As Object, wb As Workbook
Sub getDatafromAnotherfile()
Set objFso = New Scripting.FileSystemObject
Set wb = ThisWorkbook
pathname = "C:\Users\AJS-Client\Desktop\Check\GMU-Dubai21.12.2013"
Set objFolder = objFso.GetFolder(pathname)
For Each eachfile In objFolder.Files
MsgBox objFso.GetExtensionName(eachfile)
   If objFso.GetExtensionName(eachfile) = "xls" Then
 
        Call Openfile(eachfile)
   End If
 
Next
Set wb = Nothing
End Sub

Public Sub Openfile(eachfile)


Workbooks.Open eachfile

ActiveWorkbook.Sheets(1).Range("A2:C2").Copy wb.Sheets(1).Range("A2")
ActiveWorkbook.Close


End Sub