This will do the trick:
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