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

 

[igold]

Hi greenboho,

Welcome to the MrExcel Forum.

I am surprised that you can pass your filtered visible cells to an array like that, I thought you would need a For/Next loop.

That said, does this different approach meet your requirements...

Sub TableFilt()


    Dim wsR As Worksheet: Set wsR = Worksheets("Recon-I")
    Dim wsO As Worksheet: Set wsO = Worksheets("Output")
    Dim d As Object
    Dim c As Variant
    Dim i, lr As Long, x As Long
    Dim myArray As Range
    Dim Recon_I As ListObject
    
    Set Recon_I = wsR.ListObjects("Recon_I")
    Recon_I.Range.AutoFilter Field:=1, Criteria1:= _
        "Non Personnel"
    Recon_I.ListColumns("Level 2").DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
    wsO.Range("A35").PasteSpecial Paste:=xlValues
    lr = wsO.Range("A35").End(xlDown).Row


    Set myArray = Worksheets("Output").Range("A35:A" & lr)
    c = myArray
    myArray.ClearContents
    With CreateObject("Scripting.Dictionary")
        For x = LBound(c) To UBound(c)
            If Not IsMissing(c(x, 1)) Then .Item(c(x, 1)) = 1
        Next
        c = .Keys
    End With
    wsO.Range("A35").Resize(UBound(c) + 1) = Application.Transpose(c)
    
End Sub

 

[greenboho]

Hi greenboho,

Welcome to the MrExcel Forum.

I am surprised that you can pass your filtered visible cells to an array like that, I thought you would need a For/Next loop.

That said, does this different approach meet your requirements...

Sub TableFilt()


    Dim wsR As Worksheet: Set wsR = Worksheets("Recon-I")
    Dim wsO As Worksheet: Set wsO = Worksheets("Output")
    Dim d As Object
    Dim c As Variant
    Dim i, lr As Long, x As Long
    Dim myArray As Range
    Dim Recon_I As ListObject
    
    Set Recon_I = wsR.ListObjects("Recon_I")
    Recon_I.Range.AutoFilter Field:=1, Criteria1:= _
        "Non Personnel"
    Recon_I.ListColumns("Level 2").DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
    wsO.Range("A35").PasteSpecial Paste:=xlValues
    lr = wsO.Range("A35").End(xlDown).Row


    Set myArray = Worksheets("Output").Range("A35:A" & lr)
    c = myArray
    myArray.ClearContents
    With CreateObject("Scripting.Dictionary")
        For x = LBound(c) To UBound(c)
            If Not IsMissing(c(x, 1)) Then .Item(c(x, 1)) = 1
        Next
        c = .Keys
    End With
    wsO.Range("A35").Resize(UBound(c) + 1) = Application.Transpose(c)
    
End Sub

Like the I am a drinker with a coding problem - lol

I had difficulty with setting Recon_I the way you had it, I got errors. Instead I filtered and then set the range on my filtered data and then copied. I have tested it as shown below and it works. I learned a number of things from your code which is fantastic. It does work well, thank you, but do you know why a space would make the difference to it being accepted or not. As mentioned it all worked well if the filtered column was Management or Creative but as soon as it was Non Personnel or Field Personnel it did not work. I couldn't get around the space. Anyways, Thanks!!!


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 c As Variant
Dim i, lr As Long, x As Long
Dim rngdata, myArray As Range
Dim Recon_I As ListObject

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


wsR.ListObjects("Recon_I").Range.AutoFilter Field:=1, Criteria1:= _
"Non Personnel", Operator:=xlFilterValues

Set rngdata = Range("Recon_I[Level 2]").SpecialCells(xlCellTypeVisible)

rngdata.Copy
wsO.Range("A1").PasteSpecial (xlPasteValues)


Set myArray = wsO.Range("A1:A" & lr)

c = myArray

myArray.ClearContents

With d 'CreateObject("Scripting.Dictionary")

For x = LBound(c) To UBound(c)

If Not IsMissing(c(x, 1)) Then .Item(c(x, 1)) = 1

Next

c = .Keys

End With


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


End Sub

 

[igold]

I really did not understand why a space would make a difference, so I more or less ignored that part. On the other hand, I could not get your code to work for me on some fictitious data. It was for these reasons that I went in another direction.

Perhaps if you could share more of your data, the space problem could be figured out.

At any rate, I was happy to help and I hope you have it running the way you want.

Thanks for the feedback.

 

[greenboho]

I've commented out (made blue) your changes to show how the old cold worked. And as pasted below it works fine if the Non Personnel in red is any word without a space, eg. Management or Reclass. When I put Non Personnel it errors out at line For x = LBound (c) to Ubound (c) I think it is a mismatch error

I've pasted an example of my data in 3 columns (Level 1, Level 2, Level 3). For example, what I want to do is filter on Level 1 = Non Personnel and then copy the filtered data from Level 2 but only unique values and paste this to another sheet under the appropriate heading.

Ultimately I will do a loop as I have headers on my Output sheet based on Level 1 and I want to paste below these headers data from Level 2 but only unique values.

But his whole space thing has me baffled - which depends on the day is easy to do - lol.

Level 1	Level 2	Level 3
Non Personnel	Recruiting and Training - Field	Recruiting and Training - Field
Field Reps	Field Representatives	Brand Ambassador
Management	Account Management	Account Coordinator
Management	Account Management	Field Manager
Management	Account Management	Account Manager
Management	Account Management	Account Director
Non Personnel	Production, Equipment and Set-up	Production, Equipment and Set-up
Non Personnel	Production, Equipment and Set-up	Production, Equipment and Set-up
Non Personnel	Production, Equipment and Set-up	Production, Equipment and Set-up
Reclass	Other	Other
Reclass	Other	Other
Reclass	Other	Other

<colgroup><col><col span="2"></colgroup><tbody>
</tbody>

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 c As Variant
Dim i, lr x As Long
Dim rngdata, myArray As Range
Dim Recon_I As ListObject

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


wsR.ListObjects("Recon_I").Range.AutoFilter Field:=1, Criteria1:= _
"Non Personnel", Operator:=xlFilterValues

Set rngdata = Range("Recon_I[Level 2]").SpecialCells(xlCellTypeVisible)

c = rngdata ' added this

'rngdata.Copy


'wsO.Range("A1").PasteSpecial (xlPasteValues)


'Set myArray = wsO.Range("A1:A" & lr)



'myArray.ClearContents

With d 'CreateObject("Scripting.Dictionary")

For x = LBound(c) To UBound(c)

If Not IsMissing(c(x, 1)) Then .Item(c(x, 1)) = 1

Next

c = .Keys

End With


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

wsO.Range("A1").Resize(d.Count) = Application.Transpose(d.Keys)


End Sub

 

[greenboho]

oops old code , not old cold. Mind you it is cold up here in Canada - lol

 

[igold]

If it makes you feel better it's been raining all day in Florida...

This line does work perfectly for me...

ActiveSheet.ListObjects("Recon_I").Range.AutoFilter Field:=1, Criteria1:= _
        "Non Personnel", Operator:=xlFilterValues

However this line produces a single value for the array, which then makes everything below it fail because there is no array...

Set rngdata = Range("Recon_I[Level 2]").SpecialCells(xlCellTypeVisible)

I am using Excel 2010...

 

[greenboho]

Today is a beautiful sunny, finally Spring, day in the North. I have revised my code so now it works with any criteria in Level 1 that has a space (eg. Non Personnel). I get all the filtered criteria from Level 2 in my array but I can't seem to figure out how to use the scripting dictionary with my array to filter out duplicate values.

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




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



'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

If it makes you feel better it's been raining all day in Florida...

This line does work perfectly for me...

ActiveSheet.ListObjects("Recon_I").Range.AutoFilter Field:=1, Criteria1:= _
        "Non Personnel", Operator:=xlFilterValues

However this line produces a single value for the array, which then makes everything below it fail because there is no array...

Set rngdata = Range("Recon_I[Level 2]").SpecialCells(xlCellTypeVisible)

I am using Excel 2010...

 

[greenboho]

Basically, now that I have the items in an Array (as shown when it prints out). I want to put the array through the Scripting Dictionary to remove duplicates. And the paste onto another sheet.

Today is a beautiful sunny, finally Spring, day in the North. I have revised my code so now it works with any criteria in Level 1 that has a space (eg. Non Personnel). I get all the filtered criteria from Level 2 in my array but I can't seem to figure out how to use the scripting dictionary with my array to filter out duplicate values.

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




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



'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

 

[Fluff]

With data like

Excel 2013/2016
	A	B	C	D	E	F
1	Level 1	a	b	c	Level 2	Level 3
2	Non Personnel				Recruiting and Training - Field	Recruiting and Training - Field
3	Field Reps				Field Representatives	Brand Ambassador
4	Management				Account Management	Account Coordinator
5	Management				Account Management	Field Manager
6	Management				Account Management	Account Manager
7	Management				finance Management	Account Director
8	Non Personnel				Production, Equipment and Set-up	Production, Equipment and Set-up
9	Non Personnel				Production, Equipment and Set-up	Production, Equipment and Set-up
10	Non Personnel				Production, Equipment and Set-up	Production, Equipment and Set-up
11	Reclass				Other	Other
12	Reclass				anOther	Other
13	Reclass				yet anOther	Other
Recon-I

and the output sheet like

Excel 2013/2016
	A	B	C	D
1	Non Personnel	Field Reps	Management	Reclass
2
3
Output

Try

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")

   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