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

greenboho

New Member
Joined
Mar 18, 2019
Messages
12
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
 

Some videos you may like

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).

igold

Well-known Member
Joined
Jul 8, 2014
Messages
2,503
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
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...

Code:
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

New Member
Joined
Mar 18, 2019
Messages
12
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...

Code:
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

Well-known Member
Joined
Jul 8, 2014
Messages
2,503
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
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

New Member
Joined
Mar 18, 2019
Messages
12

ADVERTISEMENT

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 1Level 2Level 3
Non PersonnelRecruiting and Training - FieldRecruiting and Training - Field
Field RepsField RepresentativesBrand Ambassador
ManagementAccount ManagementAccount Coordinator
ManagementAccount ManagementField Manager
ManagementAccount ManagementAccount Manager
ManagementAccount ManagementAccount Director
Non PersonnelProduction, Equipment and Set-upProduction, Equipment and Set-up
Non PersonnelProduction, Equipment and Set-upProduction, Equipment and Set-up
Non PersonnelProduction, Equipment and Set-upProduction, Equipment and Set-up
ReclassOtherOther
ReclassOtherOther
ReclassOtherOther

<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
 

igold

Well-known Member
Joined
Jul 8, 2014
Messages
2,503
Office Version
  1. 365
  2. 2010
Platform
  1. Windows

ADVERTISEMENT

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

This line does work perfectly for me...

Code:
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...

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

I am using Excel 2010...
 

greenboho

New Member
Joined
Mar 18, 2019
Messages
12
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. :eek:

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...

Code:
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...

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

I am using Excel 2010...
 

greenboho

New Member
Joined
Mar 18, 2019
Messages
12
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. :eek:

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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
46,077
Office Version
  1. 365
Platform
  1. Windows
With data like

<b>Excel 2013/2016</b><table cellpadding="2.5px" rules="all" style=";background-color: rgb(255,255,255);border: 1px solid;border-collapse: collapse; border-color: rgb(187,187,187)"><colgroup><col width="25px" style="background-color: rgb(218,231,245)" /><col /><col /><col /><col /><col /><col /></colgroup><thead><tr style=" background-color: rgb(218,231,245);text-align: center;color: rgb(22,17,32)"><th></th><th>A</th><th>B</th><th>C</th><th>D</th><th>E</th><th>F</th></tr></thead><tbody><tr ><td style="color: rgb(22,17,32);text-align: center;">1</td><td style="font-weight: bold;text-decoration: underline;;">Level 1</td><td style="font-weight: bold;text-decoration: underline;;">a</td><td style="font-weight: bold;text-decoration: underline;;">b</td><td style="font-weight: bold;text-decoration: underline;;">c</td><td style="font-weight: bold;text-decoration: underline;;">Level 2</td><td style="font-weight: bold;text-decoration: underline;;">Level 3</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">2</td><td style=";">Non Personnel</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">Recruiting and Training - Field</td><td style=";">Recruiting and Training - Field</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">3</td><td style=";">Field Reps</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">Field Representatives</td><td style=";">Brand Ambassador</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">4</td><td style=";">Management</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">Account Management</td><td style=";">Account Coordinator</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">5</td><td style=";">Management</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">Account Management</td><td style=";">Field Manager</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">6</td><td style=";">Management</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">Account Management</td><td style=";">Account Manager</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">7</td><td style=";">Management</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">finance Management</td><td style=";">Account Director</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">8</td><td style=";">Non Personnel</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">Production, Equipment and Set-up</td><td style=";">Production, Equipment and Set-up</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">9</td><td style=";">Non Personnel</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">Production, Equipment and Set-up</td><td style=";">Production, Equipment and Set-up</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">10</td><td style=";">Non Personnel</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">Production, Equipment and Set-up</td><td style=";">Production, Equipment and Set-up</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">11</td><td style=";">Reclass</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">Other</td><td style=";">Other</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">12</td><td style=";">Reclass</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">anOther</td><td style=";">Other</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">13</td><td style=";">Reclass</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">yet anOther</td><td style=";">Other</td></tr></tbody></table><p style="width:5.6em;font-weight:bold;margin:0;padding:0.2em 0.6em 0.2em 0.5em;border: 1px solid rgb(187,187,187);border-top:none;text-align: center;background-color: rgb(218,231,245);color: rgb(22,17,32)">Recon-I</p><br /><br />

and the output sheet like

<b>Excel 2013/2016</b><table cellpadding="2.5px" rules="all" style=";background-color: rgb(255,255,255);border: 1px solid;border-collapse: collapse; border-color: rgb(187,187,187)"><colgroup><col width="25px" style="background-color: rgb(218,231,245)" /><col /><col /><col /><col /></colgroup><thead><tr style=" background-color: rgb(218,231,245);text-align: center;color: rgb(22,17,32)"><th></th><th>A</th><th>B</th><th>C</th><th>D</th></tr></thead><tbody><tr ><td style="color: rgb(22,17,32);text-align: center;">1</td><td style=";">Non Personnel</td><td style=";">Field Reps</td><td style=";">Management</td><td style=";">Reclass</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">2</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">3</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td></tr></tbody></table><p style="width:4.8em;font-weight:bold;margin:0;padding:0.2em 0.6em 0.2em 0.5em;border: 1px solid rgb(187,187,187);border-top:none;text-align: center;background-color: rgb(218,231,245);color: rgb(22,17,32)">Output</p><br /><br />

Try
Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,108,630
Messages
5,523,989
Members
409,553
Latest member
alscno

This Week's Hot Topics

Top