Function to Combine Array

Hi All,

Here is a function to combine an array columns in another array.

Private Function CombineArrayCol(ArrFirst As Variant, ArrAdd As Variant, ArrResult As Variant) As Boolean

       

      'Created By Rajan 4-July-2012

            

       '---------How to Use-------------------

       'Syntex

       'CombineArrayCol FirstArray ,SecondArray ,ResultArray

           

        '   FirstArray = FirstArray is in which second array need to be combine,Must have atleast on column and Multidimensional

        '   SecondArray = SecondArray is which need to combined with FirstArray,Must have atleast on column and Multidimensional

        '   ResultArray = ResultArray is in which combined array will be stored

        '

        ' This Function Return True if Operation is succesfull and False with NULL Result array if Operation is Not succeed

       

      Dim blnFlag As Boolean

     

      'Validating Array , IsArray

        If IsArray(ArrFirst) And IsArray(ArrAdd) Then    ' if Both Parameter is an Array

        'Both array must contain same Row Number

            If UBound(ArrFirst) = UBound(ArrAdd) Then

                ' Both Array must contain atleast One Column

                If UBound(ArrAdd, 2) < 0 Or UBound(ArrFirst, 2) < 0 Then

                    blnFlag = True

                    GoTo ExitEarly:

                    End If

            Else

                    blnFlag = True

                    GoTo ExitEarly:

                End If

        Else

            blnFlag = True

            GoTo ExitEarly:

        End If

           

    'Defining Row and Column in ResultArray

    ReDim ArrResult(LBound(ArrFirst) To UBound(ArrFirst), LBound(ArrFirst, 2) To (UBound(ArrFirst, 2) + UBound(ArrAdd, 2)))

   

    Dim lngRow As Long

    Dim lngCol As Long

    Dim lngRow2 As Long

    Dim lngCol3 As Long

   

    'Filling First Array in ResultArray

    For lngCol = LBound(ArrFirst, 2) To UBound(ArrFirst, 2)

        For lngRow = LBound(ArrFirst) To UBound(ArrFirst)

            ArrResult(lngRow, lngCol) = ArrFirst(lngRow, lngCol)

        Next lngRow

    Next lngCol

   

    lngCol = lngCol - 1

   

    'Filling Second Array in ResultArray

    For lngCol2 = LBound(ArrAdd) To UBound(ArrAdd, 2)

        For lngRow2 = LBound(ArrAdd) To UBound(ArrAdd)

            ArrResult(lngRow2, lngCol2 + lngCol) = ArrAdd(lngRow2, lngCol2)

        Next lngRow2

    Next lngCol2

ExitEarly:

      If blnFlag Then

        ArrResult = Null

        CombineArrayCol = False

      Else

        CombineArrayCol = True

      End If

End Function

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

'Test Macro

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

Sub MYTest()

   

    Dim Arr1

    Dim Arr2

    Dim Arr4

    Dim StartTime As String

    Dim StrEndTime As String

    Dim StartTime1 As String

    Dim StrEndTime1 As String

   

    Arr1 = Range("Range1")

    Arr2 = Range("Range2")

   

   

    StartTime = Time

    CombineArrayCol Arr1, Arr2, Arr3

    StrEndTime = Time

   

    StartTime1 = Now

    Range("rngOutput").Resize(UBound(Arr3), UBound(Arr3, 2)).Value = Arr3

    StrEndTime1 = Now

   

    MsgBox "Array Filling Time " & vbCrLf & _

          "Start Time = " & StartTime & vbCrLf & _

          "End Time  = " & StrEndTime & vbCrLf & vbCrLf & _

          "Range Filling Time " & vbCrLf & _

          "Start Time = " & StartTime1 & vbCrLf & _

          "End Time  = " & StrEndTime1 & vbCrLf

End Sub

Any Comment and suggestion to improve it would be highly appreciated

Thanks for reading : Rajan verma

Compile Worksheets :

if you have data in same format on multiple worksheets and you want to compile on a single sheets you can Use this Macro,

Sub ConsolidateAllSheets()

   

    Dim wksConsolidate      As Worksheet

    Dim wksSheet            As Worksheet

    Dim lngLastRow          As Long

    Set wksConsolidate = ThisWorkbook.Worksheets.Add

    lngLastRow = 1

    Application.DisplayAlerts = False

    On Error Resume Next

        ThisWorkbook.Worksheets("Consolidated").Delete

    On Error GoTo 0

   

    wksConsolidate.Name = "Consolidated"

    If Not ThisWorkbook.ProtectStructure Then

        With wksConsolidate

            For Each wksSheet In ThisWorkbook.Worksheets

                If Not wksSheet Is wksConsolidate Then

                    wksSheet.UsedRange.Copy .Range("A" & lngLastRow)

                    lngLastRow = .UsedRange.Rows.Count + 1

                End If

            Next wksSheet

        End With

    End If

    MsgBox "Done"

   

End Sub

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