Sub writetoevv()
Application.ScreenUpdating = False
Dim LastRow As Long, rng As Range, val As Range, scrWS As Worksheet, desWB As Workbook
Set srcws = ThisWorkbook.Sheets("Sheet1")
LastRow = srcws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set desWB = Workbooks.Add
For Each rng In srcws.Range("A1:A" & LastRow)
Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = rng
For Each val In srcws.Range("B" & rng.Row & ":E" & rng.Row)
If val.Interior.ColorIndex = 43 Then
Cells(Rows.Count, val.Column + 1).End(xlUp).Offset(1, 0) = Cells(Rows.Count, val.Column + 1).End(xlUp).Offset(1, 0) & val & "::1;;"
Else
Cells(Rows.Count, val.Column + 1).End(xlUp).Offset(1, 0) = Cells(Rows.Count, val.Column + 1).End(xlUp).Offset(1, 0) & val & "::0;;"
End If
Next val
Next rng
Application.ScreenUpdating = True
End Sub