Access - Excel - One to Many - Single row

[Aurayai]

Hi All,

This is my first post however i have been using the forum for a while, unfortunately i cannot find an answer to this particular problem.

I have exported data from an access database. There is a one-to-many relationship between a clients details and the clients plans.Therefore the clients details are duplicated whilst the plans are unique per row. I would idealy like each plan on the same row. Below is an example of my current data set;

Name:	Address:	Plan
Sam Tarly	Address 1	Plan A
Sam Tarly	Address 1	Plan B
John Snow	Address 2	Plan A
Arya Stark	Address 3	Plan B
Arya Stark	Address 3	Plan C

<tbody>
</tbody>

Below would be my desired outcome;

Sam Tarly	Address 1	Plan A	Plan B
John Snow	Address 2	Plan A
Arya Stark	Address 3	Plan B	Plan C

<tbody>
</tbody>

Any help would be greatly appreciated, the simpler the better!

Kind Regards,

Chris

 

[Pretty1996]

Quickly of the top of my head, could you put this info into a pivot table in Excel? That way if you put Name, Address, Plan in that order into Row Labels of the pivot table you will see the Name Listed with the Addresses and Plans?

 

[farmerscott]

Hi,

Wigi put together this VBA code for me. See if you can adapt it.

Looping and then summing duplicates/triplicates- on the 12/2/13.

Farmerscott

 

[Aurayai]

Thanks both of you for the quick reply, unfortunately i cannot use a pivot table, the format must be a plain excel document as i need to supply this to our printing company in the format above.
Is there a way to concatenate and only show the last row per client?

Thanks again

 

[Pretty1996]

I'm only an amature when it comes to VBA programming so there probably are better ways of doing this, but I got some results with this code.

This assumes your info is in Columns A to C.

Public Sub Test()
ActiveSheet.Range("A1:B65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ActiveSheet.Range("E1"), Unique:=True
'Sub Find_Last()
Application.ScreenUpdating = False
    Dim findstring As String
    Dim rng As Range
    Dim x As String
    
    Range("E" & Cells.Rows.Count).End(xlUp).Select
    ActiveCell.Offset(1, 0).Value = "End"
    Range("E2").Select
  
    Do
    x = ActiveCell.Address
    
    findstring = ActiveCell
    
    If Trim(findstring) <> "" Then
        With Sheets("Sheet1").Range("A:A")
            Set rng = .Find(What:=findstring, _
                            After:=.Cells(1), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False)
            If Not rng Is Nothing Then
                Application.Goto rng, True
                Range(x).Offset(0, 2) = ActiveCell.Offset(0, 2).Value
            End If
        End With
    End If
    
    Range(x).Select
    
    ActiveCell.Offset(1, 0).Select
    
    Loop Until ActiveCell.Value = "End"
        Range("E" & Cells.Rows.Count).End(xlUp).Select
        ActiveCell = ""
Application.ScreenUpdating = True
End Sub

so for Sam Tarly it will only show you Plan B.


Hope that helps.

~ Sukh

 

[Aurayai]

Thanks Sukh, this is close to perfect, however i have never used vb within excel therefore i am struggling to alter your example script.

I have concatenated the plans field and now have this;

Sam Tarly	Address 1	Plan A
Sam Tarly	Address 1	Plan A; Plan B
John Snow	Address 2	Plan A
Arya Stark	Address 3	Plan B
Arya Stark	Address 3	Plan B; Plan C

<tbody>
</tbody>

Unfortunately the Macro doesn't pinpoint the last plan per person when i have done this (but it works perfectly when i have not!)

Any more help would be brilliant,

Thanks again ^^/

 

[Pretty1996]

Hi Aurayai,

I've amended the code a little and now it kinda goes back to what you originally wanted.

Hope that helps. (PS. It's a little messy)

Public Sub Test()
ActiveSheet.Range("A1:B65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ActiveSheet.Range("E1"), Unique:=True
'Sub Find_Last()
Application.ScreenUpdating = False
    Dim findstring As String
    Dim rng As Range
    Dim x As String
    Dim y As String
    
    Range("E" & Cells.Rows.Count).End(xlUp).Select
    ActiveCell.Offset(1, 0).Value = "End"
    Range("E2").Select
  
    Do
    
    x = ActiveCell.Address
    
    findstring = ActiveCell
    
    If Trim(findstring) <> "" Then
        With Sheets("Sheet1").Range("A:A")
            Set rng = .Find(What:=findstring, _
                            After:=.Cells(1), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False)
            If Not rng Is Nothing Then
                Application.Goto rng, True
                Range(x).Offset(0, 2) = ActiveCell.Offset(0, 2).Value
            End If
        End With
    End If
    
    Range(x).Select
    
    ActiveCell.Offset(1, 0).Select
    
    Loop Until ActiveCell.Value = "End"
        Range("E" & Cells.Rows.Count).End(xlUp).Select
        
    Range("G2").Select
    
    Do
    
    Dim avarSplit As Variant
    Dim intIndex As Integer
    
    y = ActiveCell.Address
    
    avarSplit = Split(Range(y).Value, ";")
    For intIndex = LBound(avarSplit) To UBound(avarSplit)
    If intIndex = 4 Then
        ActiveCell.Offset(0, 1) = avarSplit(0)
        ActiveCell.Offset(0, 2) = avarSplit(1)
        ActiveCell.Offset(0, 3) = avarSplit(2)
        ActiveCell.Offset(0, 2) = avarSplit(1)
        ActiveCell.Offset(0, 3) = avarSplit(2)
    ElseIf intIndex = 3 Then
        ActiveCell.Offset(0, 1) = avarSplit(0)
        ActiveCell.Offset(0, 2) = avarSplit(1)
        ActiveCell.Offset(0, 3) = avarSplit(0)
        ActiveCell.Offset(0, 4) = avarSplit(1)
    ElseIf intIndex = 2 Then
        ActiveCell.Offset(0, 1) = avarSplit(0)
        ActiveCell.Offset(0, 2) = avarSplit(1)
        ActiveCell.Offset(0, 3) = avarSplit(2)
    ElseIf intIndex = 1 Then
        ActiveCell.Offset(0, 1) = avarSplit(0)
        ActiveCell.Offset(0, 2) = avarSplit(1)
    Else
        ActiveCell.Offset(0, 1) = avarSplit(0)
    End If
    
    Next
    ActiveCell.Offset(1, 0).Select
    Loop Until ActiveCell.Offset(0, -2) = "End"
    ActiveCell.Offset(0, -2) = ""
    
    Columns("G:G").Select
    Selection.Delete Shift:=xlToLeft
    
    Application.Goto Range("A1"), True
    
Application.ScreenUpdating = True
End Sub