XL 2016 Visible Cells into Array after filter

[R_da]

Hello Everyone,

i'm new to vba and I want to make a filter depending on some criteria and then copy the visible cells into an array.
I made the code below but it takes even the hidden cells values.
Can anyone please help me?
Sub BOM_extract()

Dim i As Long
Dim lastline As Long
Dim code_obj As String

Set Datasheet = Sheets("Data")
Set TSheet = Sheets("Raw_data")

Datasheet.Select
Selection.AutoFilter

Datasheet.Select
Datasheet.Range("$A$2:$EI$254").AutoFilter Field:=11, Criteria1:="Table"

lastline = Datasheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1

Dim my_code_obj() As String
ReDim my_code_obj(1 To lastline)

For i = 1 To lastline

my_code_obj(i) = Range("A3").Offset(1).SpecialCells(xlCellTypeVisible).Cells(i, 1).Value

Next i

TSheet.Select
Range("B3:B" & lastline).Value = Excel.WorksheetFunction.Transpose(my_code_obj)

End Sub


it would be appreciated

 

[Dranreb]

Hello.
Try this :

Sub BOM_extract()
   Dim Datasheet As Worksheet, TSheet As Worksheet, FltRng As Range, MyCodeObj(), _
      Area As Range, TbInput(), Ri As Long, Rf As Long
   Set Datasheet = Sheets("Data")
   Set TSheet = Sheets("Raw_data")
   Datasheet.Select
   Selection.AutoFilter
   Datasheet.Range("$A$2:$EI$254").AutoFilter Field:=11, Criteria1:="Table"
   Set FltRng = Datasheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible)
   ReDim MyCodeObj(1 To Datasheet.UsedRange.Rows.Count, 1 To 1)
   For Each Area In FltRng.Areas
      If Area.Rows.Count > 1 Then
         TbInput = Area.Value
         For Ri = 1 To UBound(TbInput, 1)
            Rf = Rf + 1
            MyCodeObj(Rf, 1) = TbInput(Ri, 1)
            Next Ri
      Else
         Rf = Rf + 1
         MyCodeObj(Rf, 1) = Area.Value
         End If
      Next Area
   TSheet.Select
   TSheet.[B3].Resize(UBound(MyCodeObj, 1)).Value = MyCodeObj
   End Sub

 

[Dudu2]

Bonjour @R_da, @Dranreb

Here is another option based on @R_da original code.

I do not understand what were these 2 instructions for (I removed them):
Datasheet.Select
Selection.AutoFilter
If no filters on, the program crashes.

Edit: at the end, no need to transpose, Excel can deal with the 1 dimension table.

Option Explicit

Sub BOM_extract()
    Dim Datasheet As Worksheet
    Dim TSheet As Worksheet
    Dim i As Long
    Dim lastline As Long
    Dim my_code_obj() As Variant
    Dim Cell As Range

    Set Datasheet = Sheets("Data")
    Set TSheet = Sheets("Raw_data")

    'Filter Datasheet
    Datasheet.Range("$A$2:$EI$254").AutoFilter Field:=11, Criteria1:="Table"

    'Line of the last cell filtered on Datasheet column #1
    lastline = Datasheet.Cells(Rows.Count, 1).End(xlUp).Row

    'Dimension the table to the number of filtered cells
    ReDim my_code_obj(1 To Datasheet.Range("A3:A" & lastline).SpecialCells(xlCellTypeVisible).Count)

    'Copy filtered cells into the table
    For Each Cell In Datasheet.Range("A3:A" & lastline).SpecialCells(xlCellTypeVisible)
        i = i + 1
        my_code_obj(i) = Cell.Value
    Next Cell

    'Value TSheet range with table content
    TSheet.Range("B3:B" & 3 - 1 + UBound(my_code_obj)).Value = my_code_obj
End Sub

 

[R_da]

Hello @Dranreb and @Dudu2

Thank you so much for your help, I will try and incorporate this in my file.
I have another question is what if I want to copy 2 different column, let's say column A and column D.

can I add this to the loop?

Thank you again

 

[Dranreb]

Hello.

Sub BOM_extract()
   Dim Datasheet As Worksheet, TSheet As Worksheet, FltRng As Range, TbOutput(), _
      Area As Range, TbInput(), Ri As Long, Ro As Long
   Set Datasheet = Sheets("Data")
   Set TSheet = Sheets("Raw_data")
   Datasheet.Select
   Selection.AutoFilter
   Datasheet.Range("$A$2:$EI$254").AutoFilter Field:=11, Criteria1:="Table"
   Set FltRng = Datasheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
   ReDim TbOutput(1 To Datasheet.UsedRange.Rows.Count, 1 To 2)
   For Each Area In FltRng.Areas
      TbInput = Area.Value
      For Ri = 1 To UBound(TbInput, 1)
         Ro = Ro + 1
         TbOutput(Ro, 1) = TbInput(Ri, 1) ' A
         TbOutput(Ro, 2) = TbInput(Ri, 4) ' D
         Next Ri, Area
   TSheet.Select
   TSheet.[B3:C3].Resize(UBound(TbOutput, 1)).Value = TbOutput
   End Sub

 

[Dudu2]

Bonjour,

Private Const CopyColumn1 = 1
Private Const CopyColumn2 = 4
#Const DestinationOneColumnOnly = False

Sub BOM_extract()
    Dim Datasheet As Worksheet
    Dim TSheet As Worksheet
    Dim i As Long
    Dim lastline As Long
    Dim my_code_obj() As Variant
    Dim Cell As Range

    Set Datasheet = Sheets("Data")
    Set TSheet = Sheets("Raw_data")

    'Filter Datasheet
    Datasheet.Range("$A$2:$EI$254").AutoFilter Field:=11, Criteria1:="Table"

    'Line of the last cell filtered on Datasheet column #1
    lastline = Application.Max(Datasheet.Cells(Rows.Count, CopyColumn1).End(xlUp).Row, _
                               Datasheet.Cells(Rows.Count, CopyColumn2).End(xlUp).Row)

#If DestinationOneColumnOnly Then
    'Dimension the table to the number of filtered cells * 2
    ReDim my_code_obj(1 To Datasheet.Range("A3:A" & lastline).SpecialCells(xlCellTypeVisible).Count * 2, 1 To 1)

    'Copy filtered cells into the table
    For Each Cell In Datasheet.Range("A3:A" & lastline).SpecialCells(xlCellTypeVisible)
        i = i + 1
        my_code_obj(i, 1) = Cells(i, CopyColumn1).Value
        i = i + 1
        my_code_obj(i, 1) = Cells(i, CopyColumn2).Value
    Next Cell
#Else
    'Dimension the table to the number of filtered cells
    ReDim my_code_obj(1 To Datasheet.Range("A3:A" & lastline).SpecialCells(xlCellTypeVisible).Count, 1 To 2)

    'Copy filtered cells into the table
    For Each Cell In Datasheet.Range("A3:A" & lastline).SpecialCells(xlCellTypeVisible)
        i = i + 1
        my_code_obj(i, 1) = Cells(i, CopyColumn1).Value
        my_code_obj(i, 2) = Cells(i, CopyColumn2).Value
    Next Cell
#End If

    'Value TSheet range with table content
    TSheet.Range("B3:B" & 3 - 1 + UBound(my_code_obj)).Value = my_code_obj
End Sub

 

[R_da]

Hello @Dranreb and @Dudu2,

I tried implementing both solution but I was not able to succeed, the arrays are empty.

Could you help me find the problem? I attach an example of my file with the code.

thank you so much for your precious help.

 

[Dudu2]

Hello,
Do you want the 3 columns of sheet "List" to be valued with the selected lines of sheet "Data" ?

 

[R_da]

Hello
Yes, the idea is to filter the data and copy them into arrays to do some calculations
And copy everthing into the list sheet.

 

[Dudu2]

Now that's clearer with a file (at last !) to work on...

Fichier mis à jour le 14/02:2021 à 20h35

 

[Dudu2]

Note that it would be much more secure and easier to manage with Excel Tables (Tableaux structurés).

 

[R_da]

Hello @Dudu2,

Thank you so much for your help, however, I tried running the macro but it copies the hidden cells.
please can you help me?

BR

 

[Dudu2]

Hello @R_da,
Désolé, j'ai bugué !
The file has been updated, please retrieve it again.

 

[Staple1600]

Bonjour le fil

[Pour suggestion et confort de lecture]
Tous les XLDnautes ne sont pas anglophones.
Pourquoi vous ne faites pas un peu G..gle Translate ci et là ?
Histoire d'avoir un fil "bi-langue" (une première sur XLD )
[/Pour suggestion et confort de lecture]

 

[Dudu2]

@Staple1600,
Sorry, for that. FYI I don't speak English, I just speak Globish and Google does not propose this option in it's translater !