Filter Table Column, pull Results from another column into an array to filter out duplicates and paste on another sheet

[greenboho]

Greetings all, this is my first posting as I can't seem to find the answer despite some serious research.

What I need to accomplish:
1. I have a table and I want to filter on Column 1 for a specific word (in this case Management)
2. Then I want to copy the filtered results from Column 5 - ONLY UNIQUE VALUES
3. I want to copy these unique values and paste them on another Sheet

I have my code working if the value in Column 1 is one word (eg. Management). It all works. But if the value in Column 1 is two words such as shown below "Non Personnel" then the code does not work. I can't figure out why the blank space causes trouble. I have tried many different things but nothing works! I must be missing something. Can you guide me..... Thanks

Dim d As Object
Dim c As Variant
Dim i, lr As Long
Dim myArray

Set d = CreateObject("Scripting.Dictionary")



With Sheets("Recon-I")
.ListObjects("Recon_I").Range.AutoFilter Field:=1, Criteria1:= _
"Non Personnel"
Set myArray = .Range("Recon_I[Level 2]").SpecialCells(xlCellTypeVisible)

c = myArray

MsgBox UBound(c, 1)

For i = 1 To UBound(c, 1)
d(c(i, 1)) = 1
Next i
Sheets("Output").Range("A35").Resize(d.Count) = Application.Transpose(d.Keys)

End With




End Sub

 

[greenboho]

Thank you, I will try that. I did finally get something to work but I will try your solution and reply my findings. Thank you all again. Stay warm and keep smiling

Sub GetUniqueList()
Dim wsR As Worksheet: Set wsR = Worksheets("Recon-I")
Dim wsO As Worksheet: Set wsO = Worksheets("Output")
Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
Dim rngVisible As Range
Dim rCell As Range, MyArray() As Variant
Dim x, c As Variant
Dim i, lr As Long
Dim Recon_I As ListObject




    R = Cells(Rows.Count, 1).End(xlUp).Row


        
        wsR.ListObjects("Recon_I").Range.AutoFilter Field:=1, Criteria1:= _
        "Non Personnel", Operator:=xlFilterValues 'Filter Level 1 first column on "Non Personnel"
        
    
            Set rngVisible = Range("Recon_I[Level 2]").SpecialCells(xlCellTypeVisible) 'set the visible range on Level 2
 
        
                For Each rCell In rngVisible 'Loop through visible range and populate the array
                
                    i = i + 1
                    ReDim Preserve MyArray(1 To i)
                    MyArray(i) = rCell
                    
                    
                    
                    MsgBox MyArray(i) 'Message box shows everything in Array so I can see it is working
                    
                Next rCell
                
    
                Set d = CreateObject("Scripting.Dictionary") 'puts my array into a dictionary to remove duplicates
    
                    For Each el In MyArray
                       d(el) = 1
                    Next
                    
                    
                    c = d.Keys 'Assign the Keys to an array
                    
                    'At this point, c is an array of unique values.
                    '   Do whatever you want with it:
                    
                    
                    wsO.Range("A1").Resize(UBound(c) + 1).Value = Application.Transpose(c) 'Paste list to Output page
  


End Sub

 

[Fluff]

For reference, when posting code please use code tags, the # icon in the reply window.
Also please do not quote whole posts as it just clutter up the thread
Cheers

 

[igold]

Hi,

I think your big issue is with this line:

Set rngVisible = Range("Recon_I[Level 2]").SpecialCells(xlCellTypeVisible) 'Set the visible range on Level 2

if you run your code with the following RED lines inserted, it will show you the contents of the rngVisible range. It appears to be the first 4 cells of the table, ignoring the xlCellTypeVisible...

Sub GetUniqueList()
Dim wsR As Worksheet: Set wsR = Worksheets("Recon-I")
Dim wsO As Worksheet: Set wsO = Worksheets("Dog")
Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
Dim rngVisible As Range
Dim rCell As Range, MyArray() As Variant
Dim i, lr As Long
Dim Recon_I As ListObject
Dim r As Long
Dim strRng As String


r = Cells(Rows.Count, 1).End(xlUp).Row


wsR.ListObjects("Recon_I").Range.AutoFilter Field:=1, Criteria1:= _
"Non Personnel", Operator:=xlFilterValues 'Filter Level 1 first column on "Non Personnel"




Set rngVisible = Range("Recon_I[Level 2]").SpecialCells(xlCellTypeVisible) 'Set the visible range on Level 2


[COLOR=#ff0000]For i = 1 To 4[/COLOR]
[COLOR=#ff0000]    strRng = strRng & rngVisible.Cells(i) & vbNewLine[/COLOR]
[COLOR=#ff0000]Next[/COLOR]
[COLOR=#ff0000]MsgBox "The Contents of rngVisible is:" & vbNewLine & vbNewLine & strRng[/COLOR]
[COLOR=#ff0000]Stop[/COLOR]


'Loop through visible range and populate the array
For Each rCell In rngVisible


i = i + 1
ReDim Preserve MyArray(1 To i)
MyArray(i) = rCell


MsgBox MyArray(i) 'Message box shows everything in Array but I don't want duplicates


Next rCell




End Sub

I hope this helps some...

 

[greenboho]

Thank you again for your solution. I tried it but I get an error and it stops at Cl.Offset(1).Resize(Dic(Cl.Value).Count) = Application.Transpose(Dic(Cl.Value).Keys)

Sub GetUniqueListed() Dim wsR As Worksheet: Set wsR = Worksheets("Recon-I")
Dim wsO As Worksheet: Set wsO = Worksheets("Output")
Dim Cl As Range
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")


For Each Cl In Range("Recon_I[level 1]")
If Not Dic.Exists(Cl.Value) Then Dic.Add Cl.Value, CreateObject("scripting.dictionary")
Dic(Cl.Value)(Cl.Offset(, 4).Value) = Empty
Next Cl
For Each Cl In wsO.Range("A1:D1")
Cl.Offset(1).Resize(Dic(Cl.Value).Count) = Application.Transpose(Dic(Cl.Value).Keys)
Next Cl
End Sub

 

[greenboho]

Thank you. I was going to ask why my code all left justifies even though I have it indented. I will use code tags and I will look into why I am quoting whole posts when I am replying Thanks again.

 

[Fluff]

Is your output sheet laid out like I showed in post#10
Where row 1 has the names from Level 1?

When replying use the "Reply" button, rather than the "Reply with quote"

 

[greenboho]

My Output Sheet is like a financial statement with the headings as below. I want to filter on Level One as that matches the headings and then pull data on Level 2 (or Level 3 or 4 which is dependent on the detail the user wants to see) and then copy the filtered data from Level 2 (or other Level) and remove duplicates and paste the data under the heading. So no it is not setup like the table.

I changed the code and it works but it only pastes unique values from Level 1.

c = Dic.keys

wsO.Range("A1").Resize(UBound(c) + 1).Value = Application.Transpose(c)

Field Reps

Management

Creative

Non Personnel



Sub GetUniqueListed()
Dim wsR As Worksheet: Set wsR = Worksheets("Recon-I")
Dim wsO As Worksheet: Set wsO = Worksheets("Output")
Dim Cl As Range
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")


For Each Cl In Range("Recon_I[level 1]")
If Not Dic.Exists(Cl.Value) Then Dic.Add Cl.Value, CreateObject("scripting.dictionary")
Dic(Cl.Value)(Cl.Offset(, 4).Value) = Empty
Next Cl

c = Dic.keys

wsO.Range("A1").Resize(UBound(c) + 1).Value = Application.Transpose(c)

' For Each Cl In wsO.Range("A1:D1")
' ws.Range("A1").RCl.Offset(1).Resize(Dic(Cl.Value).Count) = Application.Transpose(Dic(Cl.Value).keys)
' Next Cl
End Sub

 

[Fluff]

What are the row headers in the output sheet?
Or do you want the code to add them?

 

[greenboho]

Level 1	Level 2	Level 3	UID	Level 4	Choose Level	Output Grouping	Level 6 (Custom)
Non Personnel	Recruiting and Training - Field	Recruiting and Training - Field	1000-6470	Field Recruiting - General	3	Recruiting and Training - Field
Field Reps	Field Representatives	Brand Ambassador	1000-1011	Brand Ambassador	3	Brand Ambassador
Management	Account Management	Account Coordinator	3000-3011	Coordinator	3	Account Coordinator
Management	Account Management	Field Manager	3000-3013	Cate	3	Field Manager
Management	Account Management	Account Manager	3000-3022	Del	3	Account Manager
Management	Account Management	Account Director	3000-3042	George	3	Account Director
Non Personnel	Production, Equipment and Set-up	Production, Equipment and Set-up	9000-6370	GIF Software & Tech Support	3	Production, Equipment and Set-up
Non Personnel	Production, Equipment and Set-up	Production, Equipment and Set-up	9000-6415	Miscellaneous	3	Production, Equipment and Set-up
Non Personnel	Production, Equipment and Set-up	Production, Equipment and Set-up	9000-6465	Setup & Teardown	3	Production, Equipment and Set-up
Reclass	Other	Other		Reclass Required	4	Reclass Required
Reclass	Other	Other		Reclass Submitted	3	Other
Reclass	Other	Other		Reclass Posted	3	Other

<tbody>
</tbody>

I took your code and modified it and it seems to be working except for what is in red but I added what is in green. I won't ever want the header columns. Just the data filtered and duplicates removed. From my data I have it set so the user chooses which level they want to see on the Output Page. I will always look to Output Grouping as that pulls from Levels 1 to Level 5 based on what user puts in Choose Level.

So my full goal is to filter on Level 1 for Field Reps and then go to the Filtered Data (visible cells) in Output Grouping and then copy it (removing duplicates) and paste it on the Output page underneath the heading Field Reps and then repeat the process but this time for Management in Level 1 and paste below Management heading on the Output page and then repeat the process for Non Personnel ..

Sub GetUniqueList()
   Dim wsR As Worksheet: Set wsR = Worksheets("Recon-I")
   Dim wsO As Worksheet: Set wsO = Worksheets("Output")
   Dim Cl As Range
   Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
   
    R = Cells(Rows.Count, 1).End(xlUp).Row


        
        wsR.ListObjects("Recon_I").Range.AutoFilter Field:=1, Criteria1:= _
        "Non Personnel", Operator:=xlFilterValues 'Filter Level 1 first column on "Non Personnel"
        
    
            Set rngVisible = Range("Recon_I[Level 2]").SpecialCells(xlCellTypeVisible) 'set the visible range on Level 2
 


   For Each Cl In rngVisible
      If Not Dic.Exists(Cl.Value) Then Dic.Add Cl.Value, CreateObject("scripting.dictionary")
      Dic(Cl.Value)(Cl.Offset(, 4).Value) = Empty
   Next Cl
   
   c = Dic.keys
   
[COLOR=#006400]   wsO.Range("A1").Resize(UBound(c) + 1).Value = Application.Transpose(c)[/COLOR]
   
'   [COLOR=#ff0000]For Each Cl In wsO.Range("A1:D1")[/COLOR]
[COLOR=#ff0000]'      ws.Range("A1").RCl.Offset(1).Resize(Dic(Cl.Value).Count) = Application.Transpose(Dic(Cl.Value).keys)[/COLOR]
[COLOR=#ff0000]'   Next Cl[/COLOR]
End Sub

 

[Fluff]

As that is completely different from your OP, the code that I supplied won't work.

Also please remember to use code tags when posting code.
Thanks