Question

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

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

我需要将此信息转置到第二个表中：该表只有两列宽：A列包含所有雇员的列表，B列包含其分配的主管的姓名。

目前我的代码有效，但是我关心的是将列标题从第一个表复制并粘贴到第二个表中。我一直使用它的唯一方法是根据第一个表中的行数使用预定义的范围。如果我们添加/删除主管，这可能会很繁琐。

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

因此，例如，如果列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

您是否考虑过使用带有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

在粘贴新的Employee值之前，每次将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

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

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

2 个答案: