Question : Transpose data in MS Access or Excel

I have an Excel spreadsheet which has fund codes as row headings, and client numbers as column headings. Each client that has a corresponding fund has an x in the field under fund's row (see attached example - List tab). I need to create a list from this spreadsheet that shows each client and fund listed (Results Tab). Does anyone know how I can accomplish this in either Access or Excel?

Thanks.

Attachments:

Sample.xls (77 KB) (File Type Details)

Sample File

Answer : Transpose data in MS Access or Excel

The code below seems to be working in Excel.

This can be done in Access, but not quite as conveniently, as it involves a very long union query (or VBA code to basically do it for you).

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:



Sub TransposeData()
    
    Dim LastR As Long, LastC As Long
    Dim arr As Variant
    Dim DestR As Long
    Dim CounterR As Long, CounterC As Long
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationAutomatic
    End With
    
    With ThisWorkbook.Worksheets("List")
        LastR = .Cells(.Rows.Count, "a").End(xlUp).Row
        LastC = .Cells(1, .Columns.Count).End(xlToLeft).Column
        arr = .Range(.Cells(LastR, "a"), .Cells(1, LastC)).Value
    End With
    
    Worksheets.Add
    DestR = 1
    
    With ActiveSheet
        .Range("a1:c1") = Array("Client", "Code", "Fund#")
        For CounterR = 2 To UBound(arr, 1)
            For CounterC = 3 To UBound(arr, 2)
                If Trim(arr(CounterR, CounterC)) <> "" Then
                    DestR = DestR + 1
                    .Cells(DestR, 1) = arr(1, CounterC)
                    .Cells(DestR, 2) = arr(CounterR, 1)
                    .Cells(DestR, 3) = arr(CounterR, 2)
                End If
            Next
        Next
        .Columns.AutoFit
        .[a1].Sort Key1:=.[a1], Key2:=.[c2], Order1:=xlAscending, Order2:=xlAscending, Header:=xlYes
    End With
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
    
    MsgBox "Done"
    
End Sub