Sub writetoevv()
Application.ScreenUpdating = False
Dim LastRow As Long, rng As Range, val As Range, [COLOR="#FF0000"]srcWS[/COLOR] As Worksheet, desWB As Workbook, x As Long: x = 2
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 = 14 Then
Cells(x, 9) = Cells(x, 9) & val & "::1;;"
Else
Cells(x, 9) = Cells(x, 9) & val & "::0;;"
End If
Next val
x = x + 1
Next rng
Columns("I").AutoFit
Application.ScreenUpdating = True
End Sub