VBA Excel 2016 pasting Table Headers from one column, into a new table, based on the values of another column

Question

I have a table, which contains employee assignments: Each column header is the names of their supervisor; the rows underneath are the names of the employees assigned to that person.

For example, my table is approx. 12 columns wide, one column for each supervisor. Approx. 14 rows, each containing the name of an employee assigned to that supervisor.

I need to transpose this information into a second table: This table is only two columns wide: Column A contains a list of ALL the employees, and Column B contains the name of their assigned supervisor.

Presently my code works, however my concern is with copying and pasting the column headers from the first table into the second table. The only way I've been getting it to work, is to use a predefined range based on the number of rows in the first table. This can be tedious to edit if we add/remove supervisors.

My question is, can I avoid the need to use a "predefined range" for copying/pasting the table headers? Is there a way I can paste into the new table (column B) based on a row in column A?

• So for instance, if an employee in column A works for Supervisor "John Smith" (and is listed under his column in the first table; worksheets("Quality Assignments") Table 2), I want to paste the header "John Smith" in the column next to his employee. Any help/advice is greatly appreciated.

Here is my code:

' This is where J. Smith begins

    Worksheets("Employee Assignments").Range("Table2[John Smith]").Copy
With Worksheets("Supervisor Listing").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    .PasteSpecial xlPasteValues
    .PasteSpecial xlPasteFormats
End With
    Worksheets("Employee Assignments").Range("Table2[[#Headers],[John Smith]]").Copy
    Worksheets("Supervisor Listing").Select
    Range("B4:B17").Select
    ActiveSheet.Paste

' This is where J. Doe begins

    Worksheets("Employee Assignments").Range("Table2[Jane Doe]").Copy
With Worksheets("Supervisor Listing").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    .PasteSpecial xlPasteValues
    .PasteSpecial xlPasteFormats
End With
    Worksheets("Employee Assignments").Range("Table2[[#Headers],[Jane Doe]]").Copy
    Worksheets("Supervisor Listing").Select
    Range("B18:B31").Select
    ActiveSheet.Paste

Answer 1

Have you considered using named ranges with index() and match() functions?

Named ranges will expand to include inserted columns and rows (or collapse with deleting same).

index and match are great functions for pulling data attributes from a table like you are looking for here.

Answer 2

You could initialize a range variable to hold the start of your output range

Dim oRng As Range

    Set oRng = Worksheets("Supervisor Listing").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

And then after you paste the values, define the range of values you've just pasted and paste right next to it

    With Worksheets("Supervisor Listing")
        Worksheets("Employee Assignments").Range("Table2[[#Headers],[John Smith]]").Copy
        .Range(oRng, .Cells(Rows.Count, 1).End(xlUp)).Offset(0, 1).PasteSpecial xlPasteValues
        .Range(oRng, .Cells(Rows.Count, 1).End(xlUp)).Offset(0, 1).PasteSpecial xlPasteFormats
    End With

So from your example you'd get

Dim oRng As Range

    Set oRng = Worksheets("Supervisor Listing").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

    Worksheets("Employee Assignments").Range("Table2[John Smith]").Copy
    oRng.PasteSpecial xlPasteValues
    oRng.PasteSpecial xlPasteFormats

    With Worksheets("Supervisor Listing")
        Worksheets("Employee Assignments").Range("Table2[[#Headers],[John Smith]]").Copy
        .Range(oRng, .Cells(Rows.Count, 1).End(xlUp)).Offset(0, 1).PasteSpecial xlPasteValues
        .Range(oRng, .Cells(Rows.Count, 1).End(xlUp)).Offset(0, 1).PasteSpecial xlPasteFormats
    End With

    Set oRng = Worksheets("Supervisor Listing").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

    Worksheets("Employee Assignments").Range("Table2[Jane Doe]").Copy
    oRng.PasteSpecial xlPasteValues
    oRng.PasteSpecial xlPasteFormats

    With Worksheets("Supervisor Listing")
        Worksheets("Employee Assignments").Range("Table2[[#Headers],[Jane Doe]]").Copy
        .Range(oRng, .Cells(Rows.Count, 1).End(xlUp)).Offset(0, 1).PasteSpecial xlPasteValues
        .Range(oRng, .Cells(Rows.Count, 1).End(xlUp)).Offset(0, 1).PasteSpecial xlPasteFormats
    End With

Each time oRng is set to the cell below the last cell used in Column 1 of your "Supervisor Listing" sheet before your new Employee values are pasted, then oRng is referenced as a start cell and the header is pasted directly to the right with respect to the size of the range just pasted.

If you wanted to go a more dynamic route you could use something like

Dim oRng As Range
Dim t As ListObject
Dim h

    Set t = Worksheets("Employee Assignments").ListObjects("Table2")

    For Each h In t.HeaderRowRange
        Set oRng = Worksheets("Supervisor Listing").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Worksheets("Employee Assignments").Range("Table2[" & h.Value & "]").Copy
        oRng.PasteSpecial xlPasteValues
        oRng.PasteSpecial xlPasteFormats
        With Worksheets("Supervisor Listing")
            Worksheets("Employee Assignments").Range("Table2[[#Headers]," & h.Value & "]").Copy
            .Range(oRng, .Cells(Rows.Count, 1).End(xlUp)).Offset(0, 1).PasteSpecial xlPasteValues
            .Range(oRng, .Cells(Rows.Count, 1).End(xlUp)).Offset(0, 1).PasteSpecial xlPasteFormats
        End With
    Next

That would loop through all columns of your table, repeating your copy and paste actions for each header in your table.