Creating a Unique Table

  • Thread starter Thread starter Hman
  • Start date Start date
H

Hman

I have a database of customers, projects and category of
projects. I would like to create a table that would show
every project by customer by category. For examples:

Category I Category II ..
Customer 1 project a project f
project b project g
project c

Customer 2 project d project h
project e

I've tried using Pivot Table with no luck. Can anyone
think of a way to generate a table like this?

I am willing to use a commercially available Exel add-in
if it will get the job done.

Hman
 
Hi
this does not look like a databse structure. Maybe you can give a more
realistic example for 2-5 columns to understand your structure

Frank
 
Hmmm, good point.
Here is an example of the database:

Customer Project Name Category
Customer 1 Project D Category 1
Customer 1 Project F Category 2
Customer 1 Project G Category 3
Customer 1 Project K Category 1
Customer 1 Project M Category 1
Customer 2 Project B Category 2
Customer 2 Project H Category 1
Customer 3 Project E Category 2

And I want to go to a table like this:

Category 1 Category 2 Category 3
Customer 1 Project D Project F Project G
Project K
Project M
Customer 2 Project H Project B
Customer 3 Project E

Any thoughts?
Hman
 
3 columns. 1 header?

This sorts the original worksheet--so run it against a copy if that hurts!

Option Explicit
Sub testme()

Dim curWks As Worksheet
Dim newWks As Worksheet
Dim myRng As Range
Dim matchCol As Variant
Dim iRow As Long
Dim oRow As Long
Dim nextRow As Long
Dim TopRow As Long

Set curWks = Worksheets("sheet1")
Set newWks = Worksheets.Add

With curWks
Set myRng = .Range("a1:c" & .Cells(.Rows.Count, "A").End(xlUp).Row)
myRng.Sort key1:=.Range("a1"), order1:=xlAscending, _
key2:=.Range("c1"), order1:=xlAscending, _
key3:=.Range("b1"), order1:=xlAscending, _
header:=xlYes
Set myRng = .Range("C1", .Cells(.Rows.Count, "C").End(xlUp))
End With

With newWks
.Range("a1").Resize(myRng.Rows.Count, 1).Value = myRng.Value
.Range("a:a").AdvancedFilter action:=xlFilterCopy, unique:=True, _
copytorange:=.Range("b1")
.Columns(1).Delete
.Range("a2", .Cells(.Rows.Count, "A").End(xlUp)).Copy
.Range("b1").PasteSpecial Transpose:=True
.Columns(1).ClearContents
.Range("a1").Value = "CustName"
End With

nextRow = 2
TopRow = 2
With curWks
For iRow = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
If .Cells(iRow, 1).Value = .Cells(iRow - 1, 1).Value Then
'same as previous customer
Else
newWks.Cells(nextRow, 1).Value = .Cells(iRow, 1).Value
TopRow = nextRow
End If
matchCol = Application.Match(.Cells(iRow, 3).Value, _
newWks.Rows(1), 0)
If IsError(matchCol) Then
'this shouldn't happen!
MsgBox "design error!" & vbLf & "must stop!"
Exit Sub
Else
oRow = TopRow
Do
If IsEmpty(newWks.Cells(oRow, matchCol)) Then
Exit Do
Else
oRow = oRow + 1
End If
Loop
If nextRow <= oRow Then
nextRow = oRow + 1
End If
newWks.Cells(oRow, matchCol).Value = .Cells(iRow, 2).Value
End If
Next iRow
End With

End Sub
 
Dave,

It works like a charm. Thank you.

Hman
-----Original Message-----
3 columns. 1 header?

This sorts the original worksheet--so run it against a copy if that hurts!

Option Explicit
Sub testme()

Dim curWks As Worksheet
Dim newWks As Worksheet
Dim myRng As Range
Dim matchCol As Variant
Dim iRow As Long
Dim oRow As Long
Dim nextRow As Long
Dim TopRow As Long

Set curWks = Worksheets("sheet1")
Set newWks = Worksheets.Add

With curWks
Set myRng = .Range("a1:c" & .Cells
Click to expand...
(.Rows.Count, "A").End(xlUp).Row)
myRng.Sort key1:=.Range("a1"), order1:=xlAscending, _
key2:=.Range("c1"), order1:=xlAscending, _
key3:=.Range("b1"), order1:=xlAscending, _
header:=xlYes
Set myRng = .Range("C1", .Cells (.Rows.Count, "C").End(xlUp))
End With

With newWks
.Range("a1").Resize(myRng.Rows.Count, 1).Value = myRng.Value
.Range("a:a").AdvancedFilter
Click to expand...
action:=xlFilterCopy, unique:=True, _
 
Back
Top