Friday, March 30, 2012

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

Wednesday, March 14, 2012

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



Monday, March 12, 2012

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