VBA Excel 2016 вставляет заголовки таблицы из одного столбца в новую таблицу на основе значений другого столбца

Question

У меня есть таблица, которая содержит назначения сотрудников: каждый заголовок столбца - это имена их руководителя;строки под ними - имена сотрудников, назначенных этому человеку.

Например, моя таблица ок.12 столбцов в ширину, один столбец для каждого руководителя.Прибл.14 строк, каждая из которых содержит имя сотрудника, назначенного этому руководителю.

Мне нужно перенести эту информацию во вторую таблицу: эта таблица имеет ширину всего в два столбца: столбец A содержит список ВСЕХ сотрудников,и столбец B содержит имя назначенного им супервизора.

В настоящее время мой код работает, однако меня интересует копирование и вставка заголовков столбцов из первой таблицы во вторую таблицу.Единственный способ заставить его работать, это использовать предопределенный диапазон, основанный на количестве строк в первой таблице.Это может быть утомительно редактировать, если мы добавляем / удаляем супервизоры.

Мой вопрос: могу ли я избежать необходимости использовать «предопределенный диапазон» для копирования / вставки заголовков таблицы?Есть ли способ вставить в новую таблицу (столбец B) на основе строки в столбце A?

• Так, например, если сотрудник в столбце A работает на руководителя "Джон Смит" (и указан под его столбцом в первой таблице; рабочие таблицы ("Присвоения качества"), таблица 2), яхочу вставить заголовок «Джон Смит» в колонку рядом с его сотрудником.Любая помощь / совет с благодарностью.

Вот мой код:

' 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

Вы можете инициализировать переменную диапазона для хранения начала вашего выходного диапазона

Dim oRng As Range

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

А затем после вставки значений определите диапазон значений, который вы только что вставили, и вставьте прямо рядом с ним.

    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

Итак, из вашего примера вы получите

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

Каждый раз, когда oRng устанавливается в ячейку ниже последней ячейки, использованной в столбце 1 вашего листа "Supervisor Listing"перед вставкой значений нового сотрудника oRng упоминается как начальная ячейка, а заголовок вставляется прямо вправо относительно размера только что вставленного диапазона.

Если вы хотите перейти кболее динамический маршрут, вы можете использовать что-то вроде

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

Это будет циклически проходить по всем столбцам вашей таблицы, повторяя ваши действия копирования и вставки для каждого заголовка вашей таблицы.

Answer 2

Рассматривали ли вы использование именованных диапазонов с функциями index () и match ()?

Именованные диапазоны будут расширены, чтобы включить вставленные столбцы и строки (или свернутся при удалении одинаковых).

indexи match - отличные функции для извлечения атрибутов данных из таблицы, которую вы ищете здесь.