如果符合特定条件，则将特定列标题复制到新工作表

我正试图在工作表2中创build一个新的行，该工作表由行1中的值组成。

工作表1有：

  ABCDEF
 1 Bob Sam Ken Allen Henry Ed
 2是否是否是否 

我想要一个公式来创build第2页中的第1行，只有那些第2行=“是”的值。

所以表2看起来像：

ABCDEF 1 Bob Ken Henry 

这将随着工作表1中的数据更新而dynamic更新。

Answer 1

使用这个公式将工作（在工作表2中inputA1，然后向右拖动）

=IF(Sheet1!A$2:$F$2="Yes",Sheet1!A$1:$F$1,"")注意：按Ctrl + Shift + Enter作为数组input 。

编辑：我注意到，上面的公式会留下一个“否”等价的列之间的空白。 我试图得到一个公式，消除了差距，但仍然允许向右拖。 下面是这样做， 除了我不明白为什么在A1，“鲍勃”没有被返回。 它从“山姆”开始。 （也作为数组input）

 =INDEX(Sheet1!$A1:$F1,SMALL(IF(Sheet1!$A2:$F2="Yes",COLUMN(Sheet1!$A1:$F1)-COLUMN(Sheet1!$A1)+1),COLUMNS(Sheet1!$A1:B1))) 

有任何想法吗？ 我怀疑这是使用Small()的事情。 如果将其更改为Large() ，则返回的顺序相反

这是表格：

以下是使用该数组公式时Sheet2的外观：

鲍勃怎么样？

（#num只是因为没有更多的匹配，只是抛出一个IfError([array formula], "") ，以消除这一点）。

编辑2： 明白了！ 使用此公式，作为数组公式input：

=IFERROR(INDEX(Sheet1!$A1:$F1,SMALL(IF(Sheet1!$A2:$F2="Yes",COLUMN(Sheet1!$A1:$F1)-COLUMN(Sheet1!$A1)+1),COLUMNS(Sheet1!$A1:A1))),"")

（最后的范围应该是$A1:A1 ，而不是$A1:B1 ）

Answer 2

对于VBA，因为它在标签中，所以把它放在数据所在的工作表事件中：

 Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("2:2")) Is Nothing Then Dim ws As Worksheet Dim rng As Range Set ws = Worksheets("Sheet5")'change to what ever sheet your want Dim strArr() As Variant ReDim strArr(0) With Target.Parent For Each rng In .Range(.Cells(1, 1), .Cells(1, 1).End(xlToRight)) If rng.Offset(1) = "Yes" Then strArr(UBound(strArr)) = rng ReDim Preserve strArr(UBound(strArr) + 1) As Variant End If Next rng End With If ubound(strArr) > 0 then ReDim Preserve strArr(UBound(strArr) - 1) As Variant End If ws.Range("A1").Resize(, UBound(strArr) + 1).Value = strArr End If End Sub