VBA Excel 2016根据另一列的值将一列中的表头粘贴到新表中

Question

我有一个表，其中包含员工分配：每个列标题是他们主管的姓名；下面的行是分配给该人的员工的姓名。

例如，我的桌子大约是。 12 列宽，每个主管一列。大约。 14 行，每行包含分配给该主管的员工姓名。

我需要将此信息转换为第二个表：该表只有两列宽：A 列包含所有员工的列表，B 列包含他们指定主管的姓名。

目前我的代码可以正常工作，但是我担心将第一个表中的列标题复制并粘贴到第二个表中。我让它工作的唯一方法是使用基于第一个表中的行数的预定义范围。如果我们添加/删除主管，这可能会很繁琐。

我的问题是，我可以避免使用“预定义范围”来复制/粘贴表头吗？有没有一种方法可以根据 A 列中的一行粘贴到新表（B 列）中？

• 因此，例如，如果 A 列中的员工为主管“John Smith”工作（并在第一个表中他的列下列出；工作表（“质量分配”）表 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

您是否考虑过将命名范围与 index() 和 match() 函数一起使用？

命名范围将扩展为包括插入的列和行（或在删除时折叠）。

index 和 match 是从表中提取数据属性的绝佳函数，就像您在此处查找的那样。

Answer 2

你可以初始化一个范围变量来保存你的输出范围的开始

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 设置为 "Supervisor Listing" 工作表的第 1 列中使用的最后一个单元格下方的单元格，然后将 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

这将遍历表格的所有列，为表格中的每个标题重复复制和粘贴操作。