Excel VBA – Copy Filtered data using Autofilter in VBA into Array (2) - with no blank data

The macro in the “Copy Filtered data using Autofilter in VBA into Array” transfers the filtered data using autofilter comment to an array. The imperfect thing about it is that the transferred array contains the blank data in it because the size of the array equals to the size of the whole filtered range.

The easier way to solve the issue is to copy the non blank data into the new array.

Sub main()

    Dim FiltResult() As Variant

    Dim Filtersheet As Worksheet

    Dim FiltRange As Range

    Dim FiltField As Integer

    Dim FiltCrit As Variant

    Set Filtersheet = sheets("PStream")

    Set FiltRange = Filtersheet.Range("C6:F7352")

    FiltField = 1

    FiltCrit = 900

    FiltResult = Copyfilter(Filtersheet, FiltRange, FiltField, FiltCrit)

    '''''

    ''''Codes related with the filtered result

    ''''

End Sub

Function Copyfilter(Sht As Worksheet, Rng As Range, FField As Integer, Crit As Variant)

         Dim Arr() As Variant

         Dim ArrNew() As Variant

         Sht.Select

         With Sht

           Rng.AutoFilter

           RowCount = Rng.Rows.Count

           ColCount = Rng.Columns.Count

           Count = 1

           ReDim Arr(1 To RowCount, 1 To ColCount)

           Rng.AutoFilter Field:=FField, Criteria1:=Crit

            '------Copy the data to array for future use

            '----Do not include the table tilte

           For i = 2 To RowCount

                If Rng(i, 1).Rows.Hidden = False Then

                   For j = 1 To ColCount

                   Arr(Count, j) = Rng(i, j).Value

                   Next j

                   Count = Count + 1

                 End If

            Next i

           Rng.AutoFilter

        End With

        '----Copy the nonblank data into a new array

   ReDim ArrNew(1 To Count - 1, 1 To ColCount)

        For i = 1 To Count - 1

            For j = 1 To ColCount

             ArrNew(i, j) = Arr(i, j)

            Next j

        Next i

        '----Transfer the data to the main sub

         Copyfilter = ArrNew

End Function

Another way is to using ReDim Preserve Statement. The trick part is that when using Preserve, only the upper bound of the array can be changed. Otherwise the run time error is shown. I transpose the array to use the ReDim Preserve Statement to eliminated the un need elements.

Sub main2()

    Dim FiltResult() As Variant

    Dim Filtersheet As Worksheet

    Dim FiltRange As Range

    Dim FiltField As Integer

    Dim FiltCrit As Variant

    Set Filtersheet = sheets("PStream")

    Set FiltRange = Filtersheet.Range("C6:F7352")

    FiltField = 1

    FiltCrit = 9002

    FiltResult = Copyfilter(Filtersheet, FiltRange, FiltField, FiltCrit)

    '''''

    ''''Codes related with the filtered result

    ''''Filter result is transposed array

    ''''

End Sub

Function Copyfilter(Sht As Worksheet, Rng As Range, FField As Integer, Crit As Variant)

         Dim Arr() As Variant

           Sht.Select

         With Sht

           Rng.AutoFilter

           RowCount = Rng.Rows.Count

           ColCount = Rng.Columns.Count

           Count = 1

           ReDim Arr(1 To ColCount, 1 To RowCount)

           Rng.AutoFilter Field:=FField, Criteria1:=Crit

            '------Copy the data to array for future use

            '------Transpose the array, the column to row and row to column

           For i = 2 To RowCount

                If Rng(i, 1).Rows.Hidden = False Then

                   For j = 1 To ColCount

                   Arr(j, Count) = Rng(i, j).Value

                   Next j

                   Count = Count + 1

                 End If

            Next i

           Rng.AutoFilter

        End With

        'Redim the size of array, only keep the nonblank data

         ReDim Preserve Arr(1 To ColCount, 1 To Count - 1)

        '----Transfer the data to the main sub

        Copyfilter = Arr

End Function

© Copyright Exceltipsandkeys All Rights Reserved.