Indexer

hi Guys,

it took my lot of time to create home/Index tab to navigate in excel workbook, i always need it in most of dashboards ,dont you?

You can set any shape style default by right click on the shapes, it will work accordingly.

 

here is the code to create index : 

Sub CreateIndex()

    ‘–Code by Rajan

    Dim WksHomeTab As Worksheet

    Dim wksSheet As Worksheet

    Dim lngCOunter As Long

    lngCOunter = 0

    Set WksHomeTab = ThisWorkbook.Worksheets.Add

    With WksHomeTab

        .Name = “Home”

        For Each wksSheet In ThisWorkbook.Worksheets

            If wksSheet.Name <> “Home” Then

                .Range(“C4″).Offset(lngCOunter).Value = wksSheet.Name

                lngCOunter = lngCOunter + 1

            End If

        Next wksSheet

        .Range(“C4″).CurrentRegion.EntireRow.RowHeight = 25

        .Range(“C4″).Resize(, 2).EntireColumn.ColumnWidth = 30

        InsertShape WksHomeTab

        ActiveWindow.DisplayGridlines = False

        .Protect

    End With

End Sub

Sub InsertShape(wksHome As Worksheet)

    Dim rngCell As Range

    Dim ShpShape As Shape

    For Each rngCell In wksHome.Range(“C4″).CurrentRegion

        Set ShpShape = wksHome.Shapes.AddShape(msoShapeRectangle, rngCell.Offset(, 1).Left + 5, rngCell.Offset(, 1).Top + 5, 90, 20)

        ShpShape.TextFrame.Characters.Text = “View”

        ShpShape.TextFrame.HorizontalAlignment = xlHAlignCenter

        wksHome.Hyperlinks.Add ShpShape, “”, “‘” & rngCell.Value & “‘!A1″, “Click”, “”

        ShpShape.Locked = False

    Next rngCell

    Set ShpShape = wksHome.Shapes.AddShape(msoShapeFrame, wksHome.Range(“B1″).Top, wksHome.Range(“B1″).Left, wksHome.Range(“E1″).Left – wksHome.Range(“B1″).Left, wksHome.Range(“C4″).End(xlDown).Offset(2).Top – wksHome.Range(“B1″).Top)

    With ShpShape

        .Select

        Selection.ShapeRange.Adjustments.Item(1) = 0.06063

        Selection.ShapeRange.Adjustments.Item(1) = 0.05143

        .Top = wksHome.Range(“B2″).Top

        .Left = wksHome.Range(“B2″).Left

    End With

End Sub

you can download .xlsm from here

http://www.2shared.com/file/SP5mW3K7/Indexer.html

Thanks For Reading

Change Hyperlink Screentip

It may take lot of time to change screen tip of each hyperlink in Excel, here is a code can do in few seconds

here you go :

Sub ChangeHyperLinkSceenTipOnAllShape()

    ‘—————————————–

    ‘–This Procedure will change screenTip

    ‘  of Cells and Shapes in ActiveSheet

    ‘—————————————–

    Dim wksSheet As Worksheet

    Dim shpShape As Shape

    Dim objHyperLink As Hyperlink

    Dim StrScreenTip As String

    StrScreenTip = InputBox(“Enter the Screen Tip”)

    If MsgBox(“Press Yes to Change Screentip of Cells Hyperlinks” & vbCrLf & _

              “Press No to Change Screentip on Shapes Hyperlinks”, vbYesNoCancel) = vbYes Then

        For Each objHyperLink In ActiveSheet.Hyperlinks

            If TypeName(objHyperLink.Parent) = “Range” Then

                objHyperLink.ScreenTip = StrScreenTip

            End If

        Next objHyperLink

    Else

        For Each objHyperLink In ActiveSheet.Hyperlinks

            If TypeName(objHyperLink.Parent) = “Shape” Then

                objHyperLink.ScreenTip = StrScreenTip

            End If

        Next objHyperLink

    End If

End Sub

Array Class

Although VBA is a great language to manipulate office objects accordingly, but when it came to array handling  there are lack of method to handle array,

To resolve some of problems i collect and create some method and properties, see the content listed below which you can find in the class module .

Functions available in My Class Module for array handling .

Function Name	Description	Return Type
Function Offset	By This Function You can Extract any Part of an Array.. It works like Excel Offset function	Array Class Object
Function FilterArray	as name implies , you can Filter array by this function	Array Class Object
Function Sort	You can sort an array . ACS and DESC order	Array Class Object
Function IsArrayFilled	you can check weather array is empty or not	True/False
Function IsArray2Dimensional	Return True if array is 2 D	True/False
Function CombineArray	Most Important Function to Combine Two Array, Either by Rows or Columns	Array Class Object
Function Rows	you can Extract a particular Row from an Array	Array Class Object
Function Columns	you can Extract a particular Columns  from an Array	Array Class Object
Function Transpose	Just Using Normal VBA Transpose Function to Transpose Array. Limited as VBA Transpose	Array Class Object
Function GetUnique	You can Get Unique Array List by this Function	Array Class Object
Function CopyFromRecordset	you can assign an Object input Array from a Recordset	Nothing

you can find some properties of an Array object’s Listed below :

Count Read only Return Total Element Count of an array ColumnsCount Read only Return Columns Count of An array RowsCount Read only Returns Row Count of an Array HTMLBody Read only Return HTML Body of an Array Table

How to Use the Class Object:

Sub HowToUseClassArray()

    ‘Create an object of Array Class

    Dim objArray As New ClsArray

    Dim VarResultArray

    ‘Filling Created Object Array

    objArray.InputArray = Range(“A1″).CurrentRegion

    VarResultArray = objArray.GetUnique.InputArray

End Sub

Download  Class Module (http://www.2shared.com/file/qkY08BJ-/ClsArray.html)

Download .xlsm (http://www.2shared.com/file/r0vm1q5m/UsingClassArrayxlsm.html)

Thanks for Reading

Rajan Verma

Hierarchy Chart :

Hi All,

I have customize stack bar chart to a hierarchy chart by using some VBA,

This chart displays the next level data of a selected , user can select a parameter by double click on a series,

Example :

you can download  .xlsm from here

Note : You can use it with excel 2010.

Thanks for reading

Rajan Verma

Encrypt and Decrypt Text

Here is a basic Function to Encrypt and Decrypt  any text

Public Function evtEncrypt_Decrypt(strText As String, strPWD As String) As String

    Dim byteText() As Byte

    Dim bytePWD() As Byte

    Dim intPWDPos As Integer

    Dim intPWDLen As Integer

    Dim intLoop As Integer

    byteText = strText

    bytePWD = strPWD

    intPWDLen = LenB(strPWD)

    For intLoop = 0 To LenB(strText) – 1

        intPWDPos = (intLoop Mod intPWDLen)

        byteText(intLoop) = byteText(intLoop) Xor bytePWD(intPWDPos)

    Next intLoop

    evtEncrypt_Decrypt = byteText

End Function

You can download the .xlsm from here

Sub test()

    Dim strSource As String

    Dim strtargeten As String

    Dim strtargetde As String

    Dim strpass As String

    strSource = “manoj”

    strpass = “maya”

    strtargeten = evtEncrypt_Decrypt(strSource, strpass)

    strtargetde = evtEncrypt_Decrypt(strtargeten, strpass)

End Sub

Thanks for Reading

Rajan Verma

Comment Formatting

This code can be use to Format a Comment , you can make your excel cell comment bit beautiful by using below  code

 

Sub FormatComment()

 

    Dim rngRange As Range

    Dim rngCell As Range

    Dim objCom As Comment

    

    Set rngRange= Range(“rngRange”)

    For Each rngCell In rngRange

    rngCell.Comment.Delete

        Set objCom = rngCell.AddComment

        With objCom

            With .Shape

                .AutoShapeType = 5

                .Fill.ForeColor.RGB = RGB(120, 120, 120)

                .Fill.UserPicture “C:\Users\XL_LOVER\Desktop\546724.jpg”

                .Height = 100

                .Width = 100

            End With

        End With

    Next rngCell

     

End Sub

 

You can download the .xlsm from here

Rajan.

Get Random List :

Here is a code to get random list in array, you can pass top and bottom value.

Function GetRandList(ListCount As Long, Bottom As Long, Top As Long) As Variant

    Dim lngCOunt As Long

    If Bottom < Top Then

        With CreateObject(“Scripting.Dictionary”)

            Do While .Count <> ListCount

                .Item(Int(Rnd() * (Top – Bottom + 1) + Bottom)) = 0

            Loop

            GetRandList = .Keys

        End With

    Else

        GetRandList = Null

    End If

End Function

Sub MTest()

    Dim VarArr

    VarArr = GetRandList(10, 1, 10)

End Sub