Extract Array Elements :

Extract Array :

Here is a technique to extract a particular column or Row from a 2D Array

‘==============================================================================

Sub TestOnArray()

    Dim VarArr

    Dim VarArr2

    Dim VarArr3

    Dim blnFilter As Boolean

   

    Application.EnableEvents = False

    VarArr = Range("Range")

    VarArr2 = Application.Index(VarArr, , Range("rngCol").Value)

    Range("rngOutput").CurrentRegion.ClearContents

    If Range("rngCol").Value >= 0 And Range("rngCol").Value <= UBound(VarArr, 2) Then

   

        On Error Resume Next

            VarArr3 = Application.Transpose(Filter(Application.Transpose(VarArr2), Range("rngFiltervalue").Value, blnFilter))

            If IsArray(VarArr3) Then Range("rngOutput").Resize(UBound(VarArr3), UBound(VarArr3, 2)).Value = VarArr3

            Err.Clear

            Debug.Print Err.Description

        On Error GoTo 0

       

    End If

    Application.EnableEvents = True

   

End Sub

‘===========================================================================

‘================================Filter Array========================= 

How to Filter a Particular Column in Array :

============================================================================

Sub Test2FilterArray()

   

    Dim VarArrMain

    Dim varArrCol

    Dim VarArrResult

    Dim lngCounter          As Long

    Dim strFilterValue      As String

    Dim lngRowDedim         As Long

    Dim blnFilter As Boolean

   

    If Range("rngFilterType").Value = "Checked" Then blnFilter = True

   

    VarArrMain = Range("Range")

    varArrCol = Application.Index(VarArrMain, , Range("rngCol").Value)

    strFilterValue = Range("rngFiltervalue").Value

    lngRowDedim = 0

    ReDim VarArrResult(lngRowDedim)

   

   

    For lngCounter = LBound(VarArrMain) To UBound(VarArrMain)

            If varArrCol(lngCounter, 1) = strFilterValue And blnFilter Then

           

                    ReDim Preserve VarArrResult(lngRowDedim + 1)

                    strString = Join(Application.Index(VarArrMain, lngCounter), ",")

                    VarArrResult(lngRowDedim) = strString

                    lngRowDedim = lngRowDedim + 1

                   

            ElseIf varArrCol(lngCounter, 1) <> strFilterValue And Not blnFilter Then

               

                    ReDim Preserve VarArrResult(lngRowDedim + 1)

                    strString = Join(Application.Index(VarArrMain, lngCounter), ",")

                    VarArrResult(lngRowDedim) = strString

                    lngRowDedim = lngRowDedim + 1

            End If

    Next lngCounter

   

    Range("rngOutput").CurrentRegion.ClearContents

    Application.EnableEvents = False

    Range("rngOutput").Resize(UBound(VarArrResult) + 1).Value = Application.Transpose(VarArrResult)

    Application.EnableEvents = True

   

    Application.DisplayAlerts = False

        If Range("rngOutput").Value <> "" Then

            Range("rngOutput").CurrentRegion.Columns(1).TextToColumns Destination:=Range("K3"), DataType:=xlDelimited, _

                                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _

                                Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _

                                :=",", TrailingMinusNumbers:=True

        End If

    Application.DisplayAlerts = True

End Sub

‘============================================================================================ 

This Will work till 65536 Rows Only

Thanks For Reading

Split Data into Multiple Workbook

Hi,

Many times we need to make category wise separate files  from data on a worksheet, here is code that will do it for you.

Here i have a scenario ,Suppose  we have some data in a Range and 2nd Column of Range have some Categories , we want to bifurcate all Record of all Categories in different Excel Files.

Follow the  some simple Steps To Bifurcate the data with in multiple workbook, Original data will remain same.

1) Create a Name of First Cell of Data Range as "rngStart"

2) Create a Name range of First cell on another blank worksheets  as "rngRemoveDuplicate"

3) Copy Paste this Code in VBA Module 

4) Run the Macro

Note : This will save all bifurcated data file at same location where the MainData File is saved. So you can make a separate folder and can save Main Data file in that folder.

Sub SplitAllbyCode()

   

    Dim rngRange    As Range

    Dim wksSheet    As Worksheet

    Dim ArrUniqe

    Dim lngUniqeCount As Long

    Dim wbkNew          As Workbook

   

    Set wksSheet = ThisWorkbook.Worksheets("Sheet1")

    With wksSheet

        Set rngRange = Intersect(Range("rngStart").CurrentRegion, Range("rngStart").CurrentRegion.Offset(2))

        Application.ScreenUpdating = False

        rngRange.Columns(4).Copy Range("rngRemoveDuplicate")

        Range("rngRemoveDuplicate").CurrentRegion.RemoveDuplicates 1

        ArrUniqe = Range("rngRemoveDuplicate").CurrentRegion

        For lngUniqeCount = LBound(ArrUniqe) To UBound(ArrUniqe)

            Range("rngStart").CurrentRegion.Rows(2).AutoFilter 4, ArrUniqe(lngUniqeCount, 1)

            Range("rngStart").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy

            Set wbkNew = Workbooks.Add

            wbkNew.Worksheets(1).Paste

            wbkNew.SaveAs ThisWorkbook.Path & "\" & ArrUniqe(lngUniqeCount, 1)

            wbkNew.Close 1

        Next lngUniqeCount

    End With

        wksSheet.AutoFilterMode = False

        Application.ScreenUpdating = True

        Range("rngRemoveDuplicate").CurrentRegion.ClearContents

       MsgBox lngUniqeCount & "  Files has been splited, Plase find your files at " & vbCrLf & ThisWorkbook.Path

'Free Memory

Set rngRange = Nothing

Set wksSheet = Nothing

Erase ArrUniqe

Set wbkNew = Nothing

End Sub

Thanks for Reading

Hello Friends,

Like Microsoft Excel , These days Access also has a great place in organizations, where we need to handle large database by using only SQL or Access DB. So we have create a discussion forum for Ms Access where people can post queries and can get experts advice.

Group Link:

Access-SQL Group

This Group provide a way to share and get  the knowledge of this nice tool ,It’s a group to share query and solutions related to Microsoft Access database and SQL query. here people  can post their queries and can get quick solution.

So  join this group and start the discussion about  our topic

Rajan verma

Gauge Chart : [Dial Chart]

Hello world

Wanna make an Amazing Gauge Chart ?

Its Formally Known as Dial Chart,you can follow some simple steps to create.

  I have used some VBA Code to make the needle animated :

Here is the Code to Move Needle

Sub MoveNiddle()

    DoEvents

    If Range("rngNiddlePos").Value = Range("Sales").Value Then Exit Sub

    Range("rngNiddlePos").Value = Range("rngNiddlePos").Value + 1

    MoveNiddle  ' Recursive Function

End Sub

Sub Move()

    Range("rngNiddlePos").Value = 0

    MoveNiddle

End Sub  

Download Link for animated dial chart is :

http://www.2shared.com/file/VjAbZvKC/DialChart1.html



Download link for Steps - How to Create Dial Chart :
http://www.2shared.com/file/eOFOlhUY/DialChartSteps.html



Hope you will like it

Pie Chart :

Pie chart helps to visualize the percentage of data, its make a circle of 100%  by spliting other product/things percentage

here is a file you can make use for you of Pie chart


http://www.2shared.com/file/dytBu96u/PieChart.html

Thanks for reading

Waterfall chart :

A waterfall chart is an intuitive tool to visualize the cumulative effect of sequentially introduced positive or negative values. 

here is file you can download the waterfall template [Automated through VBA ] , you just need to give data and press button

http://www.2shared.com/file/1kSiTtg7/WaterFall.html

hope you  will enjoy.

Looping Through Folders and Files in VBA:

Hi Guys,
Many times we need to loop through folders , sub folders and files , i have created a code to get the folder structure of a given path


=======================================================================
Public ObjFolder As Object

Public objFso As Object

Public objFldLoop As Object

Public lngCounter As Long

Public  objFl As Object

   

'=================================================== 

               'A procedure to call the Function  LoopThroughEachFolder(objFolder)

'===================================================     

   

Sub GetFolderStructure()

'

    lngCounter = 0

    Set objFso = CreateObject("Scripting.FileSystemObject")

    With Application.FileDialog(msoFileDialogFolderPicker)

        .Show

        Set ObjFolder = objFso.GetFolder(.SelectedItems(1))

    End With

    Range("A1").Offset(lngCounter).Value = ObjFolder.Path

    LoopThroughEachFolder ObjFolder

   

End Sub

'=================================================== 

               'Function to Loop through each Sub Folders

'=================================================== 

Function LoopThroughEachFolder(fldFolder As Object)

    For Each objFldLoop In fldFolder.subFolders

    lngCounter = lngCounter + 1

    Range("A1").Offset(lngCounter).Value = objFldLoop.Path

    LoopThroughEachFolder objFldLoop

    Next

End Function

'=================================================== =========

           'In below function we have a nested loop to iterate each files also 

'=================================================== =========

Function LoopThroughEachFolder1(fldFolder As Object)

    For Each objFldLoop In fldFolder.subFolders

    lngCounter = lngCounter + 1

    Range("A1").Offset(lngCounter).Value = objFldLoop.Path

             For Each objFl In objFldLoop.Files

                Range("A1").Offset(lngCounter, 1).Value = objFl.Name

                lngCounter = lngCounter + 1

             Next

    LoopThroughEachFolder1 objFldLoop

    Next

End Function

Excel Solver :

As I study the solver, I feel this is elder brother of Goal Seek in Excel ,where we can change only one value with Goal seek , Using Solver we can provide many cell for adjusting value as per our scenario , Below is the Parameter required to solver ,

We can add many scenario to see different analysis,

Using Spreadsheets.  Spreadsheets such as Microsoft Excel provide a convenient way to build such a model.  Cells on a worksheet can hold numbers, labels, or formulas that calculate new values.

• The decision variables for a model are simply worksheet cells containing numbers that Solver can change.
• The objective is a cell containing a formula you want Solver to maximize (or minimize) by adjusting the values of the decision variable cells.
• Constraints are logical conditions on formula cells that must be satisfied (specified with <=, = or >= relations). Frontline's various Solver products provide powerful tools for solving, or optimizing, such models.

 Scree shot of Solver :

So, in the example Range A9 is an objective which  has a formula to do some calculation based on arguments provided as reference, Range A1:A8 are the static values which we are need to change by solver, By Pressing Add it will ask for range associated with some logical condition [<=] , after add the Constraints ,Press solve it will adjust the value of All cells to get the final result as you specified in ValueOf parameter.

Thanks for reading .. 

                                     

Dictionary Object :

when playing with data many times we needs to save some unique values somewhere, that time we can use dictionary object , it does not allow to store duplicate values in it, 

Dictionary object Takes two argument at the time of adding data 1) Key .2 ) Value and it returns the value by  ID, so when we need to retrieve any values just we need to give ID number , A very good example is given here to understand Dictionary object :

                      This procedure bifurcate data from one worksheet to multiple worksheets based on multiple values exist in Column "B" on Sheet1 , first it stores all the unique from B column in dictionary and then start bifurcating data.

Sub DistributeDataOnSheets()
    Set objDic = CreateObject("Scripting.Dictionary")
        If Not objDic.Exists(VarFilterData(lngLoop)) Then objDic.Add VarFilterData(lngLoop), VarFilterData(lngLoop)

    Dim VarFilterData()

    Dim objDic As Object

    Dim wksSheet As Worksheet

    Dim lngLoop As Long

    Dim rngRange As Range

    Dim wkSSheetNew As Worksheet

   

    Set wksSheet = ThisWorkbook.Worksheets("Sheet1")

    VarFilterData = Application.Transpose(Intersect(wksSheet.UsedRange, wksSheet.UsedRange.Columns(2).Offset(1)))

   

    For lngLoop = LBound(VarFilterData) To UBound(VarFilterData)

    Next lngLoop

    Application.ScreenUpdating = False

    For lngLoop = 1 To objDic.Count

        With wksSheet.UsedRange.Columns(2)

            .Replace VarFilterData(lngLoop), ""

            Set rngRange = .SpecialCells(xlCellTypeBlanks)

            rngRange.Value = VarFilterData(lngLoop)

        End With

        Application.DisplayAlerts = False

        On Error Resume Next

            ThisWorkbook.Worksheets(VarFilterData(lngLoop)).Delete

        On Error GoTo 0: On Error GoTo -1

        Application.DisplayAlerts = True

        Set wkSSheetNew = ThisWorkbook.Worksheets.Add

        wkSSheetNew.Name = VarFilterData(lngLoop)

        wksSheet.Rows(1).Copy wkSSheetNew.Range("A1")

        rngRange.EntireRow.Copy wkSSheetNew.Range("A2")

    Next lngLoop

   

    Application.ScreenUpdating = True

    MsgBox "Done"

End Sub

Hope you will like it

Looping in each IE WebBrowser

Sub LoopThroughEachIEWindow()

'Reference : Microsoft Internet Control
    
    Dim objSh    As New SHDocVw.ShellWindows
    Dim ibR     As SHDocVw.WebBrowser
    For Each ibR In objSh
        Debug.Print ibR.LocationURL
    Next
End Sub

For more Details Visit :
http://www.excelfox.com/forum/f20/looping-through-each-internet-explorer-348/

RAJAN_VERMA

Column count of Array

Sub ColumnCountofArray()
    Dim strArr()
    strArr = Range("A1:D10")
    MsgBox "Column of StrArr =" & UBound(strArr, 2)
End Sub

Array Formula ( Extract only Numeric from a string)

Here is a Array formula
where A1 has alphanumeric value

=SUM(INT(MID(A1,LARGE(--ISNUMBER(INT(MID(A1,ROW(INDIRECT("1:"&LEN(A1))),1)))*ROW(INDIRECT("1:"&LEN(A1))),ROW(INDIRECT("1:"&SUM(--ISNUMBER(INT(MID(A1,ROW(INDIRECT("1:"&LEN(A1))),1))))))),1)*10^ROW(INDIRECT("1:"&SUM(--ISNUMBER(INT(MID(A1,ROW(INDIRECT("1:"&LEN(A1))),1))))))))/10

Please share your idea to do the same.

Array Formula ( sum of digit in a cell)

Sum of Digit from a cell.
Many time we need sum of Digit which are placed in a single cell, we can use this function to get desired result

=SUM(INT(MID(A1,ROW(INDIRECT("1:"&LEN(A1))),1)))
As CSE (Ctrl+Shift+Enter)

Generating PDF from excel

Generating PDF from excel..

Sub CreatePDF()

   

    Dim wksSheet As Worksheet

    Dim blnFlag As Boolean

    Dim intI As Integer

    Dim intResult As Byte

   

    intI = 0

    intResult = Application.InputBox("Type 1 for Entire Workbook and Type 0 For Active Worksheets")

    If intResult = 0 Then

    Set wksSheet = ActiveSheet

            wksSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _

                    ThisWorkbook.Path & "\" & wksSheet.Name, Quality:=xlQualityStandard, _

                    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _

                    False

            Exit Sub

    End If

    For Each wksSheet In ThisWorkbook.Worksheets

        If WorksheetFunction.CountA(wksSheet.Cells) <> 0 Then

            If wksSheet.Visible = xlSheetHidden Then

                wksSheet.Visible = xlSheetVisible

                blnFlag = True

            End If

            wksSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _

                    ThisWorkbook.Path & "\" & wksSheet.Name, Quality:=xlQualityStandard, _

                    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _

                    False

                    intI = intI + 1

            If blnFlag = True Then

            wksSheet.Visible = xlSheetHidden

            blnFlag = False

            End If

        End If

    Next

    MsgBox intI & " Worksheet(s) has been Exported to PDF", vbInformation

   

End Sub

How to Calculate Date Difference :

Try this Function
if A1 is Project Start date and A2 is  Project End Data . You can calculate aging between them in Year,Month and date :
Use this in A3
=DatedDiff(A1,A2)



Function DatedDiff(dtStart As Date, dtEnd As Date) As String
   
    Dim ArrStart
    Dim ArrEnd
    Dim ArrResult
   
    ArrStart = Array(Year(dtStart), Month(dtStart), Day(dtStart))
    ArrEnd = Array(Year(dtEnd), Month(dtEnd), Day(dtEnd))
    ArrResult = Array(0, 0, 0)
    If ArrEnd(2) < ArrStart(2) Then
        ArrEnd(2) = ArrEnd(2) + Day(CDate(ArrEnd(1) & "-1-" & ArrEnd(0)) - 1)
        ArrEnd(1) = ArrEnd(1) - 1
    End If
    ArrResult(2) = ArrEnd(2) - ArrStart(2)
    If ArrEnd(1) < ArrStart(1) Then
        ArrEnd(1) = ArrEnd(1) + 12
        ArrEnd(0) = ArrEnd(0) - 1
    End If
    ArrResult(1) = ArrEnd(1) - ArrStart(1)
    ArrResult(0) = ArrEnd(0) - ArrStart(0)
    If dtEnd < dtStart Then
        DatedDiff = "StartDate>EndData=TRUE"
    Else
        DatedDiff = "Year= " & ArrResult(0) & " | Month= " & ArrResult(1) & " | Day= " & ArrResult(2)
    End If
    Erase ArrStart
    Erase ArrEnd
    Erase ArrResult
End Function

Filter On Only Number and Text

Using Custom filter to filter only Numeric Values in a list :

if only need to Filter on Text Values in List ..

VBA Method for Age Calculation :

Function DOB(rng As Range)
DOB = VBA.Format(VBA.DateDiff("d", rng, Date), "yy mm dd")
End Function

Text to column

Hi,
if you are finding a code such like Text to Column . it can help you


    Sub TextToColumn()
        Dim ArrList
        Dim rngCell As Range
        Dim strDelimeter    As String
        strDelimeter = Application.InputBox("Please Provide a Delimeter", "Text To Column")
        For Each rngCell In Selection
            ArrList = Split(rngCell.Value, strDelimeter)
            If WorksheetFunction.CountA(rngCell.Offset(, 1).Resize(1, UBound(ArrList) + 1)) > 1 Then
                If MsgBox("Some data can be replaced ,Do you want to Continue", vbYesNo) = vbYes Then
                    rngCell.Offset(, 1).Resize(1, UBound(ArrList) + 1).Value = ArrList
                End If
                Else
                rngCell.Offset(, 1).Resize(1, UBound(ArrList) + 1).Value = (ArrList)
                rngCell.Offset(, 1).Resize(1, UBound(ArrList) + 1).Value = rngCell.Offset(, 1).Resize(1, UBound(ArrList) + 1).Value
            End If
        Next
    End Sub

Hope you will post an excellent solution here

welcome  my followers to this quiz , you need to write a function to get the file extension through either a VBA function or inbuilt excel function

FIleName	.
Book1.Doc
Book.book1.xls
book.book1.book1.xlsx
book.book.book.book1.xlsm

Hope you will post a excellent function :)

Age Calculation :

If Current Date in A1 and Date of Birth in B2 then Put this Function to Calculate Age:

=DATEDIF(B2,B1,"Y")&" Year "&DATEDIF(B2,B1,"YM")&" Month "&DATEDIF(B2,B1,"MD")&" Days"