将具有特定值的所有单元格复制到跳过空白的另一列中

Question

我有三列,A,B和C:
列A包含名称,NAME1,NAME2等.
列B仅包含值"是"或"否".
C列假设包含A列中名称在B列中具有值"YES"的名称.

我可以说,只要列B中的值为"是",将值从列A复制到列C.非常简单:

C1=IF(B1="YES",A1,"")

但这将包括空白单元格,我不想这样做.所以我想我正在寻找一种方法来复制A列中的所有名称,在B列中使用值"YES",并将它们粘贴到C列中,跳过空白.

我确实找到了一个VBA项目,它使列中的所有单元格都具有一定的颜色.我不知道如何将其编辑成我需要的东西.这是我到目前为止提出的代码.

问题
1)运行时错误'1004'应用程序定义或对象定义错误
2)从A列复制
3)检查并删除NewRange中的重复项

编辑1:在代码中添加注释行
编辑2:使用偏移更改要从A列进行的NewRange(由于运行时错误而未经测试)
编辑3:用于复制的代码从用于粘贴到另一个工作表的代码中分离的一个工作表
编辑4:已添加用户更正@abahgat
编辑5:删除重复项

Sub RangeCopyPaste()
Dim cell As Range
Dim NewRange As Range
Dim MyCount As Long
MyCount = 1

'--> Loop through each cell in column B
'--> Add each cell in column A with value "YES" in column B to NewRange 
For Each cell In Worksheets("Sheet1").Range("B1:B30")
    If cell.Value = "YES" Then
        If MyCount = 1 Then Set NewRange = cell.Offset(0,-1)
        Set NewRange = Application.Union(NewRange, cell.Offset(0,-1))
        MyCount = MyCount + 1
    End If
Next cell

'--> Copy NewRange from inactive sheet into active sheet
NewRange.Copy Destination:=activesheet.Range("C1")

'--> Remove Duplicates
activesheet.Range("C1:C30").RemoveDuplicates

End Sub

Answer 1

没有VBA的解决方案:

C列包含如下公式:

=COUNTIF(B$1:B1;"yes")

D列包含如下公式:

=INDEX(A:A;MATCH(ROW();C:C;0))

跳过错误:

=IF(ISERROR(MATCH(ROW();C:C;0));"";INDEX(A:A;MATCH(ROW();C:C;0)))

Answer 2

这就能解决问题：

Sub RangeCopyPaste()
  Dim cell As Range
  Dim NewRange As Range
  Dim MyCount As Long
  MyCount = 1

  For Each cell In Worksheets("Sheet1").Range("B1:B30")
      If cell.Value = "YES" Then
          If MyCount = 1 Then Set NewRange = cell.Offset(0,-1)
          Set NewRange = Application.Union(NewRange, cell.Offset(0,-1))
          MyCount = MyCount + 1
      End If
  Next cell

  NewRange.Copy Destination:=activesheet.Range("D1")

End Sub