Sub Test() Dim c As PatternCanvas Dim y As Long For Each c In PatternCanvases y = c.Index With ActiveLayer.CreateRectangle(0, (y - 1) / 2, 3, y / 2) .Fill.ApplyPatternFill cdrTwoColorPattern,, y End With Next cEnd Sub