Advanced Filters 101....I think

[Mr_Ragweed]

I'm struggling with what I think should be simple. I'm using excel 2010. I have a data set with many columns, 2 of which i'm interested in. Let's say column A is "Department Name" and the Column B is "Product name". Both columns could change at any time (More depts could be added, and the products are always changing.) What i want to do is extract and pair up the unique values from each. Ex. Find the name of "dept A" and put it in column c (as a header and then find all of the products housed in "dept A" and populate them in that column. Then do the same for "Dept B". Make it a header in Column D with all of its products listed in the same column. There is no duplication of products across dept's. (Ie each product is unique to its dept).
I've tried the code on page 266 of "VBA and Macros:Excel 2010" from the MR Excel Library and it's kind of on the right path but only pulls 1 dept and doesn't put the values in the same column. (I'm aware it's not written for my placement issue).
Really scratching my head here as this seems like an obvious filter that would be used - (all products a customer bought, with each customer being a column, only i'm switching dept for customer).

Thanks in advance! The advice here is great -i gain a bunch of help just through reading/searching other posts.

 

[Mr_Ragweed]

starting over with the code:

Sub ProductSelect ()
Dim IRange as Range
Dim ORange as Range
Dim CRange as Range

FinalRow = Cells(Row.Count, 1).End(xlUp).Row
NextCol = Cells(1, Columns.Count).End(xlToLeft).Column + 2

Cells(1, NextCol).Value = Range("D1").Value
Cells(2, NextCol).Value = Range("D2").Value
Set CRange = Cells(1, NextCol).Resize(2, 1)

Range("E1"). Copy Destination:=Cells(1, NextCol + 2)
Set ORange = Cells(1, NextCol + 2)

Set IRange = Range("D1").Resize(FinalRow, NextCol - 2)
IRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=CRange, CopyToRange:=ORange, Unique:=True

LastRow = Cells(Rows.Count, NextCol + 2).End(xlUp).Row

Cells(1, NextCol + 2).Resize(LastRow, 1).Sort Key1:=Cells(1, NextCol + 2), Order1:=xlAscending, Header:=xlYes
End Sub

[End Code]

So the dept names are not in order as the data is several years compiled together so i simply cant just go through the first nine names to get the dept names.
I've tried doing this manually so I can record it, but no dice yet.

 

[Marcelo Branco]

Hi,

See if this works.
Observe the assumptions at the beginning of the code and also some comments
**Try it on a copy of your workbook***

Sub arrData()
    'Assumes: Data in Sheet1;Departments in column A and Products in column B
    'Destination sheet = Sheet2; Results in  columns A,B....
    Dim dept As Object, firstRow As Long, lastRow As Long, i As Long
    Dim dataRange As Variant, v As Variant, s As Variant, lastCol As Long, numLins As Long
    
    Set dept = CreateObject("Scripting.Dictionary")
    dept.comparemode = vbTextCompare
    
    With Sheets("Sheet1") '<-- data sheet.Adjust sheetname
        'Set first row with data. Adjust
        firstRow = 2
        'Get last row with data
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        dataRange = .Range("A" & firstRow & ":B" & lastRow).Value
    End With
    
    With dept
        For i = 1 To UBound(dataRange, 1)
            If .exists(dataRange(i, 1)) Then
                .Item(dataRange(i, 1)) = .Item(dataRange(i, 1)) & "," & dataRange(i, 2)
            Else
                .Add dataRange(i, 1), dataRange(i, 2)
            End If
        Next i
    End With
        
    With Sheets("Sheet2") '<--destination sheet. Adjust sheetname
        If Application.CountA(.Range("1:1")) Then
            lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
            .Columns("A").Resize(, lastCol).ClearContents
        Else
            lastCol = 1
        End If
            
        i = 0
        For Each v In dept.keys
            .Range("A1").Offset(, i) = v
            s = Split(dept.Item(v), ",")
            numLins = Application.Max(numLins, UBound(s) + 1)
            .Range("A1").Offset(1, i).Resize(UBound(s) + 1).Value = Application.Transpose(s)
            i = i + 1
        Next v
        
        'Tunning the results
        With .Range("A1", .Cells(numLins + 1, dept.Count))
            'Sorting by Department
            .SortSpecial Key1:=.Range("A1"), Order1:=xlAscending, Orientation:=xlSortRows
            'Adjusting column witdh
            .Columns.AutoFit
        End With
        
    End With
        
End Sub

Hope this is what you need.

M.

 

[Mr_Ragweed]

WOWSA!!! Thanks M. Thank you many times over! I knew it was possible. Sets it up exactly the way i want. The "product data" conatins duplicates, but i think i can handle that fairly easily.

I'm totally amazed/relieved right now.

 

[Marcelo Branco]

WOWSA!!! Thanks M. Thank you many times over! I knew it was possible. Sets it up exactly the way i want. The "product data" conatins duplicates, but i think i can handle that fairly easily.

I'm totally amazed/relieved right now.

Glad for helping

And thanks for the feedback.

M.

 

[Marcelo Branco]

To deal with duplicates Department- Product add the code line in blue

'Code
'Code
With dept
        For i = 1 To UBound(dataRange, 1)
            If .exists(dataRange(i, 1)) Then
                [COLOR=#0000ff]If InStr(.Item(dataRange(i, 1)), dataRange(i, 2)) = 0 Then _
[/COLOR]                    .Item(dataRange(i, 1)) = .Item(dataRange(i, 1)) & "," & dataRange(i, 2)
            Else
                .Add dataRange(i, 1), dataRange(i, 2)
            End If
        Next I
End With
'code
'code

M.