Help with displaying data

[Mitts]

Below is a sample of a table I need to contiually refresh. I download the raw
data in the same format each time. On a second worksheet I need to display
all of the data in separate boxes. Segregated by the name column.

Name Club
Ian green
Ian red
Ian green
Sharen green
Sharen blue
Andrew red
Andrew green

Name Club Name Club Name Club
Ian green Sharen green Andrew red
Ian red Sharen blue Andrew green
Ian green


The number of members name does not change, but the number of clubs
continually change. Can you please advise on a method to perform this task?

Rgds & Thanks,

 

[Roger Govier]

Hi

I think the following macro will do what you want.

Sub ListClubs()

Dim i As Long, lr As Long
Dim wss As Worksheet, wsd As Worksheet
Dim rng1 As Range, rng2 As Range
Application.ScreenUpdating = False
Set wss = ThisWorkbook.Sheets("Sheet1") ' Source
Set wsd = ThisWorkbook.Sheets("Sheet2") 'Destination
lr = wsd.Cells(Rows.Count, "A").End(xlUp).Row

wsd.Activate
Range("A1").Select
wss.Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("A1"), Unique:=True
wss.Activate
If wss.AutoFilterMode = False Then
wss.Range("A1:B1").AutoFilter
End If
For i = 2 To lr
Selection.AutoFilter Field:=1, Criteria1:=wsd.Cells(i, 1).Value
Set rng1 = wss.AutoFilter.Range.Columns(2).Cells
Set rng1 = rng1.Offset(1, -1).Resize(rng1.Rows.Count - 1, 2)
Set rng2 = rng1.SpecialCells(xlVisible)
rng2.Copy
wsd.Cells(2, 3 + (i - 2) * 2).PasteSpecial Paste:=xlPasteValues
Next i
wsd.Range("A1:B1").EntireColumn.Delete
wss.Range("A1:B1").Copy wsd.Range(Cells(1, 1), Cells(1, lr + 2))

If wss.FilterMode Then wss.ShowAllData
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Copy the Code above
Alt+F11 to invoke the VB Editor
Insert>Module
Paste code into white pane that appears
Alt+F11 to return to Excel

To use
Select sheet containing the PT's
Alt+F8 to bring up Macros
Highlight the macro name
Run

 

[Mitts]

Roger,

Thank you for the information,
When I attempt to run this macro I get an error message against line 28.

Runtime error 1004
Method 'Range' of object'_Worksheet' failed

wss.Range("A1:B1").Copy wsd.Range(Cells(1, 1), Cells(1, lr + 2))

Can you advise what is causing this issue?

Thanks,

 

[Roger Govier]

Hi

Try this slightly amended version

Sub ListClubs()

Dim i As Long, lr As Long
Dim wss As Worksheet, wsd As Worksheet
Dim rng1 As Range, rng2 As Range
Application.ScreenUpdating = False
Set wss = ThisWorkbook.Sheets("Sheet1") ' Source
Set wsd = ThisWorkbook.Sheets("Sheet2") 'Destination

wsd.Activate
Range("A1").Select
wss.Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("A1"), Unique:=True
wss.Activate
If wss.AutoFilterMode = False Then
wss.Range("A1:B1").AutoFilter
End If
lr = wsd.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To lr
Selection.AutoFilter Field:=1, Criteria1:=wsd.Cells(i, 1).Value
Set rng1 = wss.AutoFilter.Range.Columns(2).Cells
Set rng1 = rng1.Offset(1, -1).Resize(rng1.Rows.Count - 1, 2)
Set rng2 = rng1.SpecialCells(xlVisible)
rng2.Copy
wsd.Cells(2, 3 + (i - 2) * 2).PasteSpecial Paste:=xlPasteValues
Next i
wsd.Activate
wsd.Range("A1:B1").EntireColumn.Delete
wss.Range("A1:B1").Copy wsd.Range(Cells(1, 1), Cells(1, lr + 2))

If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub