Sub Test() Dim s As Shape Dim c As PatternCanvas For Each s In ActivePage.Shapes If s.Fill.Type = cdrPatternFill Then If s.Fill.Pattern.Type = cdrTwoColorPattern Then If s.Fill.Pattern.Canvas.Index <> PatternCanvases.Count Then Set c = New PatternCanvas c.Select s.Fill.Pattern.Canvas.Index + 1 s.Fill.Pattern.Canvas = c End If End If End If Next sEnd Sub