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